Mercurial > emacs
comparison lisp/mh-e/mh-mime.el @ 49459:06b77df47802
* mh-e: Created directory. ChangeLog will appear in a week when we
release version 7.2.
* lisp/mail/mh-alias.el, lisp/mail/mh-comp.el,
lisp/mail/mh-customize.el, lisp/mail/mh-e.el, lisp/mail/mh-funcs.el,
lisp/mail/mh-identity.el, lisp/mail/mh-index.el,
lisp/mail/mh-loaddefs.el, lisp/mail/mh-mime.el, lisp/mail/mh-pick.el,
lisp/mail/mh-seq.el, lisp/mail/mh-speed.el, lisp/mail/mh-utils.el,
lisp/mail/mh-xemacs-compat.el: Moved to mh-e. Note that reply2.pbm and
reply2.xpm, which were created by the MH-E package, were left in mail
since they can probably be used by other mail packages.
* makefile.w32-in (WINS): Added mh-e.
* makefile.nt (WINS): Added mh-e.
author | Bill Wohler <wohler@newt.com> |
---|---|
date | Sun, 26 Jan 2003 02:38:37 +0000 |
parents | |
children | b35587af8747 |
comparison
equal
deleted
inserted
replaced
49458:5ddabc4c81b0 | 49459:06b77df47802 |
---|---|
1 ;;; mh-mime.el --- MH-E support for composing MIME messages | |
2 | |
3 ;; Copyright (C) 1993, 1995, 2001, 2002 Free Software Foundation, Inc. | |
4 | |
5 ;; Author: Bill Wohler <wohler@newt.com> | |
6 ;; Maintainer: Bill Wohler <wohler@newt.com> | |
7 ;; Keywords: mail | |
8 ;; See: mh-e.el | |
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 2, or (at your option) | |
15 ;; 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; see the file COPYING. If not, write to the | |
24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
25 ;; Boston, MA 02111-1307, USA. | |
26 | |
27 ;;; Commentary: | |
28 | |
29 ;; Internal support for MH-E package. | |
30 ;; Support for generating an mhn composition file. | |
31 ;; MIME is supported only by MH 6.8 or later. | |
32 | |
33 ;;; Change Log: | |
34 | |
35 ;; $Id: mh-mime.el,v 1.12 2003/01/08 23:21:16 wohler Exp $ | |
36 | |
37 ;;; Code: | |
38 | |
39 (require 'cl) | |
40 (require 'mh-comp) | |
41 (require 'mh-utils) | |
42 (load "mm-decode" t t) ; Non-fatal dependency | |
43 (load "mm-uu" t t) ; Non-fatal dependency | |
44 (load "mailcap" t t) ; Non-fatal dependency | |
45 (load "smiley" t t) ; Non-fatal dependency | |
46 (require 'gnus-util) | |
47 | |
48 (autoload 'gnus-article-goto-header "gnus-art") | |
49 (autoload 'article-emphasize "gnus-art") | |
50 (autoload 'gnus-get-buffer-create "gnus") | |
51 (autoload 'gnus-eval-format "gnus-spec") | |
52 (autoload 'widget-convert-button "wid-edit") | |
53 (autoload 'message-options-set-recipient "message") | |
54 (autoload 'mml-secure-message-sign-pgpmime "mml-sec") | |
55 (autoload 'mml-secure-message-encrypt-pgpmime "mml-sec") | |
56 (autoload 'mml-minibuffer-read-file "mml") | |
57 (autoload 'mml-minibuffer-read-description "mml") | |
58 (autoload 'mml-insert-empty-tag "mml") | |
59 (autoload 'mml-to-mime "mml") | |
60 (autoload 'mml-attach-file "mml") | |
61 | |
62 ;;;###mh-autoload | |
63 (defun mh-compose-insertion (&optional inline) | |
64 "Add a directive to insert a MIME part from a file, using mhn or gnus. | |
65 If the variable `mh-compose-insertion' is set to 'mhn, then that will be used. | |
66 If it is set to 'gnus, then that will be used instead. | |
67 Optional argument INLINE means make it an inline attachment." | |
68 (interactive "P") | |
69 (if (equal mh-compose-insertion 'gnus) | |
70 (if inline | |
71 (mh-mml-attach-file "inline") | |
72 (mh-mml-attach-file)) | |
73 (call-interactively 'mh-mhn-compose-insertion))) | |
74 | |
75 ;;;###mh-autoload | |
76 (defun mh-compose-forward (&optional description folder message) | |
77 "Add a MIME directive to forward a message, using mhn or gnus. | |
78 If the variable `mh-compose-insertion' is set to 'mhn, then that will be used. | |
79 If it is set to 'gnus, then that will be used instead. | |
80 Optional argument DESCRIPTION is a description of the attachment. | |
81 Optional argument FOLDER is the folder from which the forwarded message should | |
82 come. | |
83 Optional argument MESSAGE is the message to forward. | |
84 If any of the optional arguments are absent, they are prompted for." | |
85 (interactive (list | |
86 (read-string "Forw Content-description: ") | |
87 (mh-prompt-for-folder "Message from" mh-sent-from-folder nil) | |
88 (read-string (format "Messages%s: " | |
89 (if mh-sent-from-msg | |
90 (format " [%d]" mh-sent-from-msg) | |
91 ""))))) | |
92 (if (equal mh-compose-insertion 'gnus) | |
93 (mh-mml-forward-message description folder message) | |
94 (mh-mhn-compose-forw description folder message))) | |
95 | |
96 ;; To do: | |
97 ;; paragraph code should not fill # lines if MIME enabled. | |
98 ;; implement mh-auto-edit-mhn (if non-nil, \\[mh-send-letter] | |
99 ;; invokes mh-edit-mhn automatically before sending.) | |
100 ;; actually, instead of mh-auto-edit-mhn, | |
101 ;; should read automhnproc from profile | |
102 ;; MIME option to mh-forward | |
103 ;; command to move to content-description insertion point | |
104 | |
105 (defvar mh-mhn-args nil | |
106 "Extra arguments to have \\[mh-edit-mhn] pass to the \"mhn\" command. | |
107 The arguments are passed to mhn if \\[mh-edit-mhn] is given a | |
108 prefix argument. Normally default arguments to mhn are specified in the | |
109 MH profile.") | |
110 | |
111 (defvar mh-media-type-regexp | |
112 (concat (regexp-opt '("text" "image" "audio" "video" "application" | |
113 "multipart" "message") t) | |
114 "/[-.+a-zA-Z0-9]+") | |
115 "Regexp matching valid media types used in MIME attachment compositions.") | |
116 | |
117 ;; Just defvar the variable to avoid compiler warning... This doesn't bind | |
118 ;; the variable, so things should work exactly as before. | |
119 (defvar mh-have-file-command) | |
120 | |
121 (defun mh-have-file-command () | |
122 "Return t if 'file' command is on the system. | |
123 'file -i' is used to get MIME type of composition insertion." | |
124 (when (not (boundp 'mh-have-file-command)) | |
125 (load "executable" t t) ; executable-find not autoloaded in emacs20 | |
126 (setq mh-have-file-command | |
127 (and (fboundp 'executable-find) | |
128 (executable-find "file") ; file command exists | |
129 ; and accepts -i and -b args. | |
130 (zerop (call-process "file" nil nil nil "-i" "-b" | |
131 (expand-file-name "inc" mh-progs)))))) | |
132 mh-have-file-command) | |
133 | |
134 (defvar mh-file-mime-type-substitutions | |
135 '(("application/msword" "\.xls" "application/ms-excel") | |
136 ("application/msword" "\.ppt" "application/ms-powerpoint")) | |
137 "Substitutions to make for Content-Type returned from file command. | |
138 The first element is the Content-Type returned by the file command. | |
139 The second element is a regexp matching the file name, usually the extension. | |
140 The third element is the Content-Type to replace with.") | |
141 | |
142 (defun mh-file-mime-type-substitute (content-type filename) | |
143 "Return possibly changed CONTENT-TYPE on the FILENAME. | |
144 Substitutions are made from the `mh-file-mime-type-substitutions' variable." | |
145 (let ((subst mh-file-mime-type-substitutions) | |
146 (type) (match) (answer content-type) | |
147 (case-fold-search t)) | |
148 (while subst | |
149 (setq type (car (car subst)) | |
150 match (elt (car subst) 1)) | |
151 (if (and (string-equal content-type type) | |
152 (string-match match filename)) | |
153 (setq answer (elt (car subst) 2) | |
154 subst nil) | |
155 (setq subst (cdr subst)))) | |
156 answer)) | |
157 | |
158 (defun mh-file-mime-type (filename) | |
159 "Return MIME type of FILENAME from file command. | |
160 Returns nil if file command not on system." | |
161 (cond | |
162 ((not (mh-have-file-command)) | |
163 nil) ;No file command, exit now. | |
164 ((not (and (file-exists-p filename)(file-readable-p filename))) | |
165 nil) | |
166 (t | |
167 (save-excursion | |
168 (let ((tmp-buffer (get-buffer-create mh-temp-buffer))) | |
169 (set-buffer tmp-buffer) | |
170 (unwind-protect | |
171 (progn | |
172 (call-process "file" nil '(t nil) nil "-b" "-i" | |
173 (expand-file-name filename)) | |
174 (goto-char (point-min)) | |
175 (if (not (re-search-forward mh-media-type-regexp nil t)) | |
176 nil | |
177 (mh-file-mime-type-substitute (match-string 0) filename))) | |
178 (kill-buffer tmp-buffer))))))) | |
179 | |
180 ;;; This is needed for Emacs20 which doesn't have mailcap-mime-types. | |
181 (defvar mh-mime-content-types | |
182 '(("application/mac-binhex40") ("application/msword") | |
183 ("application/octet-stream") ("application/pdf") ("application/pgp-keys") | |
184 ("application/pgp-signature") ("application/pkcs7-signature") | |
185 ("application/postscript") ("application/rtf") | |
186 ("application/vnd.ms-excel") ("application/vnd.ms-powerpoint") | |
187 ("application/vnd.ms-project") ("application/vnd.ms-tnef") | |
188 ("application/wordperfect5.1") ("application/wordperfect6.0") | |
189 ("application/zip") | |
190 | |
191 ("audio/basic") ("audio/mpeg") | |
192 | |
193 ("image/gif") ("image/jpeg") ("image/png") | |
194 | |
195 ("message/delivery-status") | |
196 ("message/external-body") ("message/partial") ("message/rfc822") | |
197 | |
198 ("text/enriched") ("text/html") ("text/plain") ("text/rfc822-headers") | |
199 ("text/richtext") ("text/xml") | |
200 | |
201 ("video/mpeg") ("video/quicktime")) | |
202 "Legal MIME content types. | |
203 See documentation for \\[mh-edit-mhn].") | |
204 | |
205 ;;;###mh-autoload | |
206 (defun mh-mhn-compose-insertion (filename type description attributes) | |
207 "Add a directive to insert a MIME message part from a file. | |
208 This is the typical way to insert non-text parts in a message. | |
209 | |
210 Arguments are FILENAME, which tells where to find the file, TYPE, the MIME | |
211 content type, DESCRIPTION, a line of text for the Content-Description field. | |
212 ATTRIBUTES is a comma separated list of name=value pairs that is appended to | |
213 the Content-Type field of the attachment. | |
214 | |
215 See also \\[mh-edit-mhn]." | |
216 (interactive (let ((filename (read-file-name "Insert contents of: "))) | |
217 (list | |
218 filename | |
219 (or (mh-file-mime-type filename) | |
220 (completing-read "Content-Type: " | |
221 (if (fboundp 'mailcap-mime-types) | |
222 (mapcar 'list (mailcap-mime-types)) | |
223 mh-mime-content-types))) | |
224 (read-string "Content-Description: ") | |
225 (read-string "Content-Attributes: " | |
226 (concat "name=\"" | |
227 (file-name-nondirectory filename) | |
228 "\""))))) | |
229 (mh-mhn-compose-type filename type description attributes )) | |
230 | |
231 (defun mh-mhn-compose-type (filename type | |
232 &optional description attributes comment) | |
233 "Insert a mhn directive to insert a file. | |
234 | |
235 The file specified by FILENAME is encoded as TYPE. An optional DESCRIPTION is | |
236 used as the Content-Description field, optional set of ATTRIBUTES and an | |
237 optional COMMENT can also be included." | |
238 (setq mh-mhn-compose-insert-flag t) | |
239 (beginning-of-line) | |
240 (insert "#" type) | |
241 (and attributes | |
242 (insert "; " attributes)) | |
243 (and comment | |
244 (insert " (" comment ")")) | |
245 (insert " [") | |
246 (and description | |
247 (insert description)) | |
248 (insert "] " (expand-file-name filename)) | |
249 (insert "\n")) | |
250 | |
251 | |
252 ;;;###mh-autoload | |
253 (defun mh-mhn-compose-anon-ftp (host filename type description) | |
254 "Add a directive for a MIME anonymous ftp external body part. | |
255 This directive tells MH to include a reference to a message/external-body part | |
256 retrievable by anonymous FTP. | |
257 | |
258 Arguments are HOST and FILENAME, which tell where to find the file, TYPE, the | |
259 MIME content type, and DESCRIPTION, a line of text for the Content-description | |
260 header. | |
261 | |
262 See also \\[mh-edit-mhn]." | |
263 (interactive (list | |
264 (read-string "Remote host: ") | |
265 (read-string "Remote filename: ") | |
266 (completing-read "External Content-Type: " | |
267 (if (fboundp 'mailcap-mime-types) | |
268 (mapcar 'list (mailcap-mime-types)) | |
269 mh-mime-content-types)) | |
270 (read-string "External Content-Description: "))) | |
271 (mh-mhn-compose-external-type "anon-ftp" host filename | |
272 type description)) | |
273 | |
274 ;;;###mh-autoload | |
275 (defun mh-mhn-compose-external-compressed-tar (host filename description) | |
276 "Add a directive to include a MIME reference to a compressed tar file. | |
277 The file should be available via anonymous ftp. This directive tells MH to | |
278 include a reference to a message/external-body part. | |
279 | |
280 Arguments are HOST and FILENAME, which tell where to find the file, and | |
281 DESCRIPTION, a line of text for the Content-description header. | |
282 | |
283 See also \\[mh-edit-mhn]." | |
284 (interactive (list | |
285 (read-string "Remote host: ") | |
286 (read-string "Remote filename: ") | |
287 (read-string "Tar file Content-description: "))) | |
288 (mh-mhn-compose-external-type "anon-ftp" host filename | |
289 "application/octet-stream" | |
290 description | |
291 "type=tar; conversions=x-compress" | |
292 "mode=image")) | |
293 | |
294 | |
295 (defun mh-mhn-compose-external-type (access-type host filename type | |
296 &optional description | |
297 attributes extra-params | |
298 comment) | |
299 "Add a directive to include a MIME reference to a remote file. | |
300 The file should be available via anonymous ftp. This directive tells MH to | |
301 include a reference to a message/external-body part. | |
302 | |
303 Arguments are ACCESS-TYPE, HOST and FILENAME, which tell where to find the | |
304 file and TYPE which is the MIME Content-Type. Optional arguments include | |
305 DESCRIPTION, a line of text for the Content-description header, ATTRIBUTES, | |
306 EXTRA-PARAMS, and COMMENT. | |
307 | |
308 See also \\[mh-edit-mhn]." | |
309 (setq mh-mhn-compose-insert-flag t) | |
310 (beginning-of-line) | |
311 (insert "#@" type) | |
312 (and attributes | |
313 (insert "; " attributes)) | |
314 (and comment | |
315 (insert " (" comment ") ")) | |
316 (insert " [") | |
317 (and description | |
318 (insert description)) | |
319 (insert "] ") | |
320 (insert "access-type=" access-type "; ") | |
321 (insert "site=" host) | |
322 (insert "; name=" (file-name-nondirectory filename)) | |
323 (insert "; directory=\"" (file-name-directory filename) "\"") | |
324 (and extra-params | |
325 (insert "; " extra-params)) | |
326 (insert "\n")) | |
327 | |
328 ;;;###mh-autoload | |
329 (defun mh-mhn-compose-forw (&optional description folder messages) | |
330 "Add a forw directive to this message, to forward a message with MIME. | |
331 This directive tells MH to include the named messages in this one. | |
332 | |
333 Arguments are DESCRIPTION, a line of text for the Content-description header, | |
334 and FOLDER and MESSAGES, which name the message(s) to be forwarded. | |
335 | |
336 See also \\[mh-edit-mhn]." | |
337 (interactive (list | |
338 (read-string "Forw Content-description: ") | |
339 (mh-prompt-for-folder "Message from" mh-sent-from-folder nil) | |
340 (read-string (format "Messages%s: " | |
341 (if mh-sent-from-msg | |
342 (format " [%d]" mh-sent-from-msg) | |
343 ""))))) | |
344 (setq mh-mhn-compose-insert-flag t) | |
345 (beginning-of-line) | |
346 (insert "#forw [") | |
347 (and description | |
348 (not (string= description "")) | |
349 (insert description)) | |
350 (insert "]") | |
351 (and folder | |
352 (not (string= folder "")) | |
353 (insert " " folder)) | |
354 (if (and messages | |
355 (not (string= messages ""))) | |
356 (let ((start (point))) | |
357 (insert " " messages) | |
358 (subst-char-in-region start (point) ?, ? )) | |
359 (if mh-sent-from-msg | |
360 (insert " " (int-to-string mh-sent-from-msg)))) | |
361 (insert "\n")) | |
362 | |
363 ;;;###mh-autoload | |
364 (defun mh-edit-mhn (&optional extra-args) | |
365 "Format the current draft for MIME, expanding any mhn directives. | |
366 | |
367 Process the current draft with the mhn program, which, using directives | |
368 already inserted in the draft, fills in all the MIME components and header | |
369 fields. | |
370 | |
371 This step should be done last just before sending the message. | |
372 | |
373 The `\\[mh-revert-mhn-edit]' command undoes this command. The arguments in the | |
374 list `mh-mhn-args' are passed to mhn if this function is passed an optional | |
375 prefix argument EXTRA-ARGS. | |
376 | |
377 For assistance with creating mhn directives to insert various types of | |
378 components in a message, see \\[mh-mhn-compose-insertion] (generic insertion | |
379 from a file), \\[mh-mhn-compose-anon-ftp] (external reference to file via | |
380 anonymous ftp), \\[mh-mhn-compose-external-compressed-tar] \ \(reference to | |
381 compressed tar file via anonymous ftp), and \\[mh-mhn-compose-forw] (forward | |
382 message). If these helper functions are used, `mh-edit-mhn' is run | |
383 automatically when the draft is sent. | |
384 | |
385 The value of `mh-edit-mhn-hook' is a list of functions to be called, with no | |
386 arguments, after performing the conversion. | |
387 | |
388 The mhn program is part of MH version 6.8 or later." | |
389 (interactive "*P") | |
390 (save-buffer) | |
391 (message "mhn editing...") | |
392 (cond | |
393 (mh-nmh-flag | |
394 (mh-exec-cmd-error nil | |
395 "mhbuild" (if extra-args mh-mhn-args) buffer-file-name)) | |
396 (t | |
397 (mh-exec-cmd-error (format "mhdraft=%s" buffer-file-name) | |
398 "mhn" (if extra-args mh-mhn-args) buffer-file-name))) | |
399 (setq mh-mhn-compose-insert-flag nil) | |
400 (revert-buffer t t) | |
401 (message "mhn editing...done") | |
402 (run-hooks 'mh-edit-mhn-hook)) | |
403 | |
404 ;;;###mh-autoload | |
405 (defun mh-revert-mhn-edit (noconfirm) | |
406 "Undo the effect of \\[mh-edit-mhn] by reverting to the backup file. | |
407 Optional non-nil argument NOCONFIRM means don't ask for confirmation." | |
408 (interactive "*P") | |
409 (if (null buffer-file-name) | |
410 (error "Buffer does not seem to be associated with any file")) | |
411 (let ((backup-strings '("," "#")) | |
412 backup-file) | |
413 (while (and backup-strings | |
414 (not (file-exists-p | |
415 (setq backup-file | |
416 (concat (file-name-directory buffer-file-name) | |
417 (car backup-strings) | |
418 (file-name-nondirectory buffer-file-name) | |
419 ".orig"))))) | |
420 (setq backup-strings (cdr backup-strings))) | |
421 (or backup-strings | |
422 (error "Backup file for %s no longer exists!" buffer-file-name)) | |
423 (or noconfirm | |
424 (yes-or-no-p (format "Revert buffer from file %s? " | |
425 backup-file)) | |
426 (error "Revert not confirmed")) | |
427 (let ((buffer-read-only nil)) | |
428 (erase-buffer) | |
429 (insert-file-contents backup-file)) | |
430 (after-find-file nil))) | |
431 | |
432 | |
433 | |
434 ;;; MIME composition functions | |
435 | |
436 ;;;###mh-autoload | |
437 (defun mh-mml-to-mime () | |
438 "Compose MIME message from mml directives." | |
439 (interactive) | |
440 (when mh-gnus-pgp-support-flag ;; This is only needed for PGP | |
441 (message-options-set-recipient)) | |
442 (mml-to-mime) | |
443 (setq mh-mml-compose-insert-flag nil)) | |
444 | |
445 ;;;###mh-autoload | |
446 (defun mh-mml-forward-message (description folder message) | |
447 "Forward a message as attachment. | |
448 The function will prompt the user for a DESCRIPTION, a FOLDER and MESSAGE | |
449 number." | |
450 (let ((msg (if (equal message "") | |
451 mh-sent-from-msg | |
452 (car (read-from-string message))))) | |
453 (cond ((integerp msg) | |
454 (if (string= "" description) | |
455 ;; Rationale: mml-attach-file constructs a malformed composition | |
456 ;; if the description string is empty. This fixes SF #625168. | |
457 (mml-attach-file (format "%s%s/%d" | |
458 mh-user-path (substring folder 1) msg) | |
459 "message/rfc822") | |
460 (mml-attach-file (format "%s%s/%d" | |
461 mh-user-path (substring folder 1) msg) | |
462 "message/rfc822" | |
463 description)) | |
464 (setq mh-mml-compose-insert-flag t)) | |
465 (t (error "The message number, %s is not a integer!" msg))))) | |
466 | |
467 ;;;###mh-autoload | |
468 (defun mh-mml-attach-file (&optional disposition) | |
469 "Attach a file to the outgoing MIME message. | |
470 The file is not inserted or encoded until you send the message with | |
471 `\\[mh-send-letter]'. | |
472 Message disposition is \"inline\" or \"attachment\" and is prompted for if | |
473 DISPOSITION is nil. | |
474 | |
475 This is basically `mml-attach-file' from gnus, modified such that a prefix | |
476 argument yields an `inline' disposition and Content-Type is determined | |
477 automatically." | |
478 (let* ((file (mml-minibuffer-read-file "Attach file: ")) | |
479 (type (or (mh-file-mime-type file) | |
480 (completing-read "Content-Type: " | |
481 (if (fboundp 'mailcap-mime-types) | |
482 (mapcar 'list (mailcap-mime-types)) | |
483 mh-mime-content-types)))) | |
484 (description (mml-minibuffer-read-description)) | |
485 (dispos (or disposition | |
486 (completing-read "Disposition: [attachment] " | |
487 '(("attachment")("inline")) | |
488 nil t nil nil | |
489 "attachment")))) | |
490 (mml-insert-empty-tag 'part 'type type 'filename file | |
491 'disposition dispos 'description description) | |
492 (setq mh-mml-compose-insert-flag t))) | |
493 | |
494 ;;;###mh-autoload | |
495 (defun mh-mml-secure-message-sign-pgpmime () | |
496 "Add directive to encrypt/sign the entire message." | |
497 (interactive) | |
498 (if (not mh-gnus-pgp-support-flag) | |
499 (error "Sorry. Your version of gnus does not support PGP/GPG") | |
500 (mml-secure-message-sign-pgpmime) | |
501 (setq mh-mml-compose-insert-flag t))) | |
502 | |
503 ;;;###mh-autoload | |
504 (defun mh-mml-secure-message-encrypt-pgpmime (&optional dontsign) | |
505 "Add directive to encrypt and sign the entire message. | |
506 If called with a prefix argument DONTSIGN, only encrypt (do NOT sign)." | |
507 (interactive "P") | |
508 (if (not mh-gnus-pgp-support-flag) | |
509 (error "Sorry. Your version of gnus does not support PGP/GPG") | |
510 (mml-secure-message-encrypt-pgpmime dontsign) | |
511 (setq mh-mml-compose-insert-flag t))) | |
512 | |
513 | |
514 | |
515 ;;; MIME decoding | |
516 | |
517 (defmacro mh-defun-compat (function arg-list &rest body) | |
518 "This is a macro to define functions which are not defined. | |
519 It is used for Gnus utility functions which were added recently. If FUNCTION | |
520 is not defined then it is defined to have argument list, ARG-LIST and body, | |
521 BODY." | |
522 (let ((defined-p (fboundp function))) | |
523 (unless defined-p | |
524 `(defun ,function ,arg-list ,@body)))) | |
525 (put 'mh-defun-compat 'lisp-indent-function 'defun) | |
526 | |
527 ;; Copy of original function from gnus-util.el | |
528 (mh-defun-compat gnus-local-map-property (map) | |
529 "Return a list suitable for a text property list specifying keymap MAP." | |
530 (cond (mh-xemacs-flag (list 'keymap map)) | |
531 ((>= emacs-major-version 21) (list 'keymap map)) | |
532 (t (list 'local-map map)))) | |
533 | |
534 ;; Copy of original function from mm-decode.el | |
535 (mh-defun-compat mm-merge-handles (handles1 handles2) | |
536 (append (if (listp (car handles1)) handles1 (list handles1)) | |
537 (if (listp (car handles2)) handles2 (list handles2)))) | |
538 | |
539 ;; Copy of function from mm-decode.el | |
540 (mh-defun-compat mm-set-handle-multipart-parameter (handle parameter value) | |
541 ;; HANDLE could be a CTL. | |
542 (if handle | |
543 (put-text-property 0 (length (car handle)) parameter value | |
544 (car handle)))) | |
545 | |
546 ;; Copy of original macro is in mm-decode.el | |
547 (mh-defun-compat mm-handle-multipart-ctl-parameter (handle parameter) | |
548 (get-text-property 0 parameter (car handle))) | |
549 | |
550 ;; Copy of original function in mm-decode.el | |
551 (mh-defun-compat mm-readable-p (handle) | |
552 "Say whether the content of HANDLE is readable." | |
553 (and (< (with-current-buffer (mm-handle-buffer handle) | |
554 (buffer-size)) 10000) | |
555 (mm-with-unibyte-buffer | |
556 (mm-insert-part handle) | |
557 (and (eq (mm-body-7-or-8) '7bit) | |
558 (not (mm-long-lines-p 76)))))) | |
559 | |
560 ;; Copy of original function in mm-bodies.el | |
561 (mh-defun-compat mm-long-lines-p (length) | |
562 "Say whether any of the lines in the buffer is longer than LINES." | |
563 (save-excursion | |
564 (goto-char (point-min)) | |
565 (end-of-line) | |
566 (while (and (not (eobp)) | |
567 (not (> (current-column) length))) | |
568 (forward-line 1) | |
569 (end-of-line)) | |
570 (and (> (current-column) length) | |
571 (current-column)))) | |
572 | |
573 (mh-defun-compat mm-keep-viewer-alive-p (handle) | |
574 ;; Released Gnus doesn't keep handles associated with externally displayed | |
575 ;; MIME parts. So this will always return nil. | |
576 nil) | |
577 | |
578 (mh-defun-compat mm-destroy-parts (list) | |
579 "Older emacs don't have this function." | |
580 nil) | |
581 | |
582 ;;; This is mm-save-part from gnus 5.10 since that function in emacs21.2 is | |
583 ;;; buggy (the args to read-file-name are incorrect). When all supported | |
584 ;;; versions of Emacs come with at least Gnus 5.10, we can delete this | |
585 ;;; function and rename calls to mh-mm-save-part to mm-save-part. | |
586 (defun mh-mm-save-part (handle) | |
587 "Write HANDLE to a file." | |
588 (let ((name (mail-content-type-get (mm-handle-type handle) 'name)) | |
589 (filename (mail-content-type-get | |
590 (mm-handle-disposition handle) 'filename)) | |
591 file) | |
592 (when filename | |
593 (setq filename (file-name-nondirectory filename))) | |
594 (setq file (read-file-name "Save MIME part to: " | |
595 (or mm-default-directory | |
596 default-directory) | |
597 nil nil (or filename name ""))) | |
598 (setq mm-default-directory (file-name-directory file)) | |
599 (and (or (not (file-exists-p file)) | |
600 (yes-or-no-p (format "File %s already exists; overwrite? " | |
601 file))) | |
602 (mm-save-part-to-file handle file)))) | |
603 | |
604 | |
605 | |
606 ;;; MIME cleanup | |
607 | |
608 ;;;###mh-autoload | |
609 (defun mh-mime-cleanup () | |
610 "Free the decoded MIME parts." | |
611 (let ((mime-data (gethash (current-buffer) mh-globals-hash))) | |
612 ;; This is for Emacs, what about XEmacs? | |
613 (cond ((fboundp 'remove-images) | |
614 (remove-images (point-min) (point-max)))) | |
615 (when mime-data | |
616 (mm-destroy-parts (mh-mime-handles mime-data)) | |
617 (remhash (current-buffer) mh-globals-hash)))) | |
618 | |
619 ;;;###mh-autoload | |
620 (defun mh-destroy-postponed-handles () | |
621 "Free MIME data for externally displayed mime parts." | |
622 (let ((mime-data (mh-buffer-data))) | |
623 (when mime-data | |
624 (mm-destroy-parts (mh-mime-handles mime-data))) | |
625 (remhash (current-buffer) mh-globals-hash))) | |
626 | |
627 (defun mh-handle-set-external-undisplayer (folder handle function) | |
628 "Replacement for `mm-handle-set-external-undisplayer'. | |
629 This is only called in recent versions of Gnus. The MIME handles are stored | |
630 in data structures corresponding to MH-E folder buffer FOLDER instead of in | |
631 Gnus (as in the original). The MIME part, HANDLE is associated with the | |
632 undisplayer FUNCTION." | |
633 (if (mm-keep-viewer-alive-p handle) | |
634 (let ((new-handle (copy-sequence handle))) | |
635 (mm-handle-set-undisplayer new-handle function) | |
636 (mm-handle-set-undisplayer handle nil) | |
637 (save-excursion | |
638 (set-buffer folder) | |
639 (push new-handle (mh-mime-handles (mh-buffer-data))))) | |
640 (mm-handle-set-undisplayer handle function))) | |
641 | |
642 | |
643 | |
644 ;;; MIME transformations | |
645 (eval-when-compile (require 'font-lock)) | |
646 | |
647 ;;;###mh-autoload | |
648 (defun mh-add-missing-mime-version-header () | |
649 "Some mail programs don't put a MIME-Version header. | |
650 I have seen this only in spam, so maybe we shouldn't fix this ;-)" | |
651 (save-excursion | |
652 (goto-char (point-min)) | |
653 (when (and (message-fetch-field "content-type") | |
654 (not (message-fetch-field "mime-version"))) | |
655 (when (search-forward "\n\n" nil t) | |
656 (forward-line -1) | |
657 (insert "MIME-Version: 1.0\n"))))) | |
658 | |
659 ;;;###mh-autoload | |
660 (defun mh-display-smileys () | |
661 "Function to display smileys." | |
662 (when (and mh-graphical-smileys-flag | |
663 (fboundp 'smiley-region) | |
664 (boundp 'font-lock-maximum-size) | |
665 (>= (/ font-lock-maximum-size 8) (buffer-size))) | |
666 (smiley-region (point-min) (point-max)))) | |
667 | |
668 ;;;###mh-autoload | |
669 (defun mh-display-emphasis () | |
670 "Function to display graphical emphasis." | |
671 (when (and mh-graphical-emphasis-flag | |
672 (boundp 'font-lock-maximum-size) | |
673 (>= (/ font-lock-maximum-size 8) (buffer-size))) | |
674 (flet ((article-goto-body ())) ; shadow this function to do nothing | |
675 (save-excursion | |
676 (goto-char (point-min)) | |
677 (article-emphasize))))) | |
678 | |
679 ;; Copied from gnus-art.el (should be checked for other cool things that can | |
680 ;; be added to the buttons) | |
681 (defvar mh-mime-button-commands | |
682 '((mh-press-button "\r" "Toggle Display"))) | |
683 (defvar mh-mime-button-map | |
684 (let ((map (make-sparse-keymap))) | |
685 (unless (>= (string-to-number emacs-version) 21) | |
686 ;; XEmacs doesn't care. | |
687 (set-keymap-parent map mh-show-mode-map)) | |
688 (define-key map [mouse-2] 'mh-push-button) | |
689 (dolist (c mh-mime-button-commands) | |
690 (define-key map (cadr c) (car c))) | |
691 map)) | |
692 (defvar mh-mime-button-line-format-alist | |
693 '((?T long-type ?s) | |
694 (?d description ?s) | |
695 (?p index ?s) | |
696 (?e dots ?s))) | |
697 (defvar mh-mime-button-line-format "%{%([%p. %d%T]%)%}%e\n") | |
698 (defvar mh-mime-security-button-pressed nil) | |
699 (defvar mh-mime-security-button-line-format "%{%([[%t:%i]%D]%)%}\n") | |
700 (defvar mh-mime-security-button-end-line-format "%{%([[End of %t]%D]%)%}\n") | |
701 (defvar mh-mime-security-button-line-format-alist | |
702 '((?t type ?s) | |
703 (?i info ?s) | |
704 (?d details ?s) | |
705 (?D pressed-details ?s))) | |
706 (defvar mh-mime-security-button-map | |
707 (let ((map (make-sparse-keymap))) | |
708 (unless (>= (string-to-number emacs-version) 21) | |
709 (set-keymap-parent map mh-show-mode-map)) | |
710 (define-key map "\r" 'mh-press-button) | |
711 (define-key map [mouse-2] 'mh-push-button) | |
712 map)) | |
713 | |
714 (defvar mh-mime-save-parts-directory nil | |
715 "Default to use for `mh-mime-save-parts-default-directory'. | |
716 Set from last use.") | |
717 | |
718 ;;;###mh-autoload | |
719 (defun mh-mime-save-parts (arg) | |
720 "Store the MIME parts of the current message. | |
721 If ARG, prompt for directory, else use that specified by the variable | |
722 `mh-mime-save-parts-default-directory'. These directories may be superseded by | |
723 mh_profile directives, since this function calls on mhstore or mhn to do the | |
724 actual storing." | |
725 (interactive "P") | |
726 (let ((msg (if (eq major-mode 'mh-show-mode) | |
727 (mh-show-buffer-message-number) | |
728 (mh-get-msg-num t))) | |
729 (folder (if (eq major-mode 'mh-show-mode) | |
730 mh-show-folder-buffer | |
731 mh-current-folder)) | |
732 (command (if mh-nmh-flag "mhstore" "mhn")) | |
733 (directory | |
734 (cond | |
735 ((and (or arg | |
736 (equal nil mh-mime-save-parts-default-directory) | |
737 (equal t mh-mime-save-parts-default-directory)) | |
738 (not mh-mime-save-parts-directory)) | |
739 (read-file-name "Store in what directory? " nil nil t nil)) | |
740 ((and (or arg | |
741 (equal t mh-mime-save-parts-default-directory)) | |
742 mh-mime-save-parts-directory) | |
743 (read-file-name (format | |
744 "Store in what directory? [%s] " | |
745 mh-mime-save-parts-directory) | |
746 "" mh-mime-save-parts-directory t "")) | |
747 ((stringp mh-mime-save-parts-default-directory) | |
748 mh-mime-save-parts-default-directory) | |
749 (t | |
750 mh-mime-save-parts-directory)))) | |
751 (if (and (equal directory "") mh-mime-save-parts-directory) | |
752 (setq directory mh-mime-save-parts-directory)) | |
753 (if (not (file-directory-p directory)) | |
754 (message "No directory specified.") | |
755 (if (equal nil mh-mime-save-parts-default-directory) | |
756 (setq mh-mime-save-parts-directory directory)) | |
757 (save-excursion | |
758 (set-buffer (get-buffer-create " *mh-store*")) | |
759 (cd directory) | |
760 (setq mh-mime-save-parts-directory directory) | |
761 (erase-buffer) | |
762 (apply 'call-process | |
763 (expand-file-name command mh-progs) nil t nil | |
764 (mh-list-to-string (list folder msg "-auto"))) | |
765 (if (> (buffer-size) 0) | |
766 (save-window-excursion | |
767 (switch-to-buffer-other-window " *mh-store*") | |
768 (sit-for 3))))))) | |
769 | |
770 ;; Avoid errors if gnus-sum isn't loaded yet... | |
771 (defvar gnus-newsgroup-charset nil) | |
772 (defvar gnus-newsgroup-name nil) | |
773 | |
774 ;;;###mh-autoload | |
775 (defun mh-mime-display (&optional pre-dissected-handles) | |
776 "Display (and possibly decode) MIME handles. | |
777 Optional argument, PRE-DISSECTED-HANDLES is a list of MIME handles. If | |
778 present they are displayed otherwise the buffer is parsed and then | |
779 displayed." | |
780 (let ((handles ()) | |
781 (folder mh-show-folder-buffer)) | |
782 (flet ((mm-handle-set-external-undisplayer | |
783 (handle function) | |
784 (mh-handle-set-external-undisplayer folder handle function))) | |
785 ;; If needed dissect the current buffer | |
786 (if pre-dissected-handles | |
787 (setq handles pre-dissected-handles) | |
788 (setq handles (or (mm-dissect-buffer nil) (mm-uu-dissect))) | |
789 (setf (mh-mime-handles (mh-buffer-data)) | |
790 (mm-merge-handles handles (mh-mime-handles (mh-buffer-data))))) | |
791 | |
792 (when (and handles (or (not (stringp (car handles))) (cdr handles))) | |
793 ;; Goto start of message body | |
794 (goto-char (point-min)) | |
795 (or (search-forward "\n\n" nil t) (goto-char (point-max))) | |
796 | |
797 ;; Delete the body | |
798 (delete-region (point) (point-max)) | |
799 | |
800 ;; Display the MIME handles | |
801 (mh-mime-display-part handles))))) | |
802 | |
803 (defun mh-mime-display-part (handle) | |
804 "Decides the viewer to call based on the type of HANDLE." | |
805 (cond ((null handle) nil) | |
806 ((not (stringp (car handle))) | |
807 (mh-mime-display-single handle)) | |
808 ((equal (car handle) "multipart/alternative") | |
809 (mh-mime-display-alternative (cdr handle))) | |
810 ((and mh-gnus-pgp-support-flag | |
811 (or (equal (car handle) "multipart/signed") | |
812 (equal (car handle) "multipart/encrypted"))) | |
813 (mh-mime-display-security handle)) | |
814 (t (mh-mime-display-mixed (cdr handle))))) | |
815 | |
816 (defun mh-mime-display-alternative (handles) | |
817 "Choose among the alternatives, HANDLES the part that will be displayed. | |
818 If no part is preferred then all the parts are displayed." | |
819 (let ((preferred (mm-preferred-alternative handles))) | |
820 (cond ((and preferred (stringp (car preferred))) | |
821 (mh-mime-display-part preferred)) | |
822 (preferred | |
823 (save-restriction | |
824 (narrow-to-region (point) (if (eobp) (point) (1+ (point)))) | |
825 (mh-mime-display-single preferred) | |
826 (goto-char (point-max)))) | |
827 (t (mh-mime-display-mixed handles))))) | |
828 | |
829 (defun mh-mime-display-mixed (handles) | |
830 "Display the list of MIME parts, HANDLES recursively." | |
831 (mapcar #'mh-mime-display-part handles)) | |
832 | |
833 (defun mh-mime-part-index (handle) | |
834 "Generate the button number for MIME part, HANDLE. | |
835 Notice that a hash table is used to display the same number when buttons need | |
836 to be displayed multiple times (for instance when nested messages are | |
837 opened)." | |
838 (or (gethash handle (mh-mime-part-index-hash (mh-buffer-data))) | |
839 (setf (gethash handle (mh-mime-part-index-hash (mh-buffer-data))) | |
840 (incf (mh-mime-parts-count (mh-buffer-data)))))) | |
841 | |
842 ;;; Avoid compiler warnings for XEmacs functions... | |
843 (eval-when (compile) | |
844 (loop for function in '(glyph-width window-pixel-width | |
845 glyph-height window-pixel-height) | |
846 do (or (fboundp function) (defalias function 'ignore)))) | |
847 | |
848 (defun mh-small-image-p (handle) | |
849 "Decide whether HANDLE is a \"small\" image that can be displayed inline. | |
850 This is only useful if a Content-Disposition header is not present." | |
851 (let ((media-test (caddr (assoc (car (mm-handle-type handle)) | |
852 mh-mm-inline-media-tests))) | |
853 (mm-inline-large-images t)) | |
854 (and media-test | |
855 (equal (mm-handle-media-supertype handle) "image") | |
856 (funcall media-test handle) ; Since mm-inline-large-images is T, | |
857 ; this only tells us if the image is | |
858 ; something that emacs can display | |
859 (let* ((image (mm-get-image handle))) | |
860 (cond ((fboundp 'glyph-width) | |
861 ;; XEmacs -- totally untested, copied from gnus | |
862 (and (< (glyph-width image) | |
863 (or mh-max-inline-image-width | |
864 (window-pixel-width))) | |
865 (< (glyph-height image) | |
866 (or mh-max-inline-image-height | |
867 (window-pixel-height))))) | |
868 ((fboundp 'image-size) | |
869 ;; Emacs21 -- copied from gnus | |
870 (let ((size (image-size image))) | |
871 (and (< (cdr size) | |
872 (or mh-max-inline-image-height | |
873 (1- (window-height)))) | |
874 (< (car size) | |
875 (or mh-max-inline-image-width (window-width)))))) | |
876 (t | |
877 ;; Can't show image inline | |
878 nil)))))) | |
879 | |
880 (defun mh-inline-vcard-p (handle) | |
881 "Decide if HANDLE is a vcard that must be displayed inline." | |
882 (let ((type (mm-handle-type handle))) | |
883 (and (consp type) | |
884 (equal (car type) "text/x-vcard") | |
885 (save-excursion | |
886 (save-restriction | |
887 (widen) | |
888 (goto-char (point-min)) | |
889 (not (re-search-forward "^-- $" nil t))))))) | |
890 | |
891 (defun mh-mime-display-single (handle) | |
892 "Display a leaf node, HANDLE in the MIME tree." | |
893 (let* ((type (mm-handle-media-type handle)) | |
894 (small-image-flag (mh-small-image-p handle)) | |
895 (attachmentp (equal (car (mm-handle-disposition handle)) | |
896 "attachment")) | |
897 (inlinep (and (equal (car (mm-handle-disposition handle)) "inline") | |
898 (mm-inlinable-p handle) | |
899 (mm-inlined-p handle))) | |
900 (displayp (or inlinep ; show if inline OR | |
901 (mh-inline-vcard-p handle); inline vcard OR | |
902 (and (not attachmentp) ; if not an attachment | |
903 (or small-image-flag ; and small image | |
904 ; and user wants inline | |
905 (and (not (equal | |
906 (mm-handle-media-supertype handle) | |
907 "image")) | |
908 (mm-inlinable-p handle) | |
909 (mm-inlined-p handle))))))) | |
910 (save-restriction | |
911 (narrow-to-region (point) (if (eobp) (point) (1+ (point)))) | |
912 (cond ((and mh-gnus-pgp-support-flag | |
913 (equal type "application/pgp-signature")) | |
914 nil) ; skip signatures as they are already handled... | |
915 ((not displayp) | |
916 (insert "\n") | |
917 (mh-insert-mime-button handle (mh-mime-part-index handle) nil)) | |
918 ((and displayp (not mh-display-buttons-for-inline-parts-flag)) | |
919 (or (mm-display-part handle) (mm-display-part handle))) | |
920 ((and displayp mh-display-buttons-for-inline-parts-flag) | |
921 (insert "\n") | |
922 (mh-insert-mime-button handle (mh-mime-part-index handle) nil) | |
923 (forward-line -1) | |
924 (mh-mm-display-part handle))) | |
925 (goto-char (point-max))))) | |
926 | |
927 (defun mh-insert-mime-button (handle index displayed) | |
928 "Insert MIME button for HANDLE. | |
929 INDEX is the part number that will be DISPLAYED. It is also used by commands | |
930 like \"K v\" which operate on individual MIME parts." | |
931 ;; The button could be displayed by a previous decode. In that case | |
932 ;; undisplay it if we need a hidden button. | |
933 (when (and (mm-handle-displayed-p handle) (not displayed)) | |
934 (mm-display-part handle)) | |
935 (let ((name (or (mail-content-type-get (mm-handle-type handle) 'name) | |
936 (mail-content-type-get (mm-handle-disposition handle) | |
937 'filename) | |
938 (mail-content-type-get (mm-handle-type handle) 'url) | |
939 "")) | |
940 (type (mm-handle-media-type handle)) | |
941 (description (mail-decode-encoded-word-string | |
942 (or (mm-handle-description handle) ""))) | |
943 (dots (if (or displayed (mm-handle-displayed-p handle)) " " "...")) | |
944 long-type begin end) | |
945 (if (string-match ".*/" name) (setq name (substring name (match-end 0)))) | |
946 (setq long-type (concat type (and (not (equal name "")) | |
947 (concat "; " name)))) | |
948 (unless (equal description "") | |
949 (setq long-type (concat " --- " long-type))) | |
950 (unless (bolp) (insert "\n")) | |
951 (setq begin (point)) | |
952 (gnus-eval-format | |
953 mh-mime-button-line-format mh-mime-button-line-format-alist | |
954 `(,@(gnus-local-map-property mh-mime-button-map) | |
955 mh-callback mh-mm-display-part | |
956 mh-part ,index | |
957 mh-data ,handle)) | |
958 (setq end (point)) | |
959 (widget-convert-button | |
960 'link begin end | |
961 :mime-handle handle | |
962 :action 'mh-widget-press-button | |
963 :button-keymap mh-mime-button-map | |
964 :help-echo | |
965 "Mouse-2 click or press RET (in show buffer) to toggle display"))) | |
966 | |
967 ;; There is a bug in Gnus inline image display due to which an extra line | |
968 ;; gets inserted every time it is viewed. To work around that problem we are | |
969 ;; using an extra property 'mh-region to remember the region that is added | |
970 ;; when the button is clicked. The region is then deleted to make sure that | |
971 ;; no extra lines get inserted. | |
972 (defun mh-mm-display-part (handle) | |
973 "Toggle display of button for MIME part, HANDLE." | |
974 (beginning-of-line) | |
975 (let ((id (get-text-property (point) 'mh-part)) | |
976 (point (point)) | |
977 (window (selected-window)) | |
978 (mail-parse-charset 'nil) | |
979 (mail-parse-ignored-charsets nil) | |
980 region buffer-read-only) | |
981 (save-excursion | |
982 (unwind-protect | |
983 (let ((win (get-buffer-window (current-buffer) t))) | |
984 (when win | |
985 (select-window win)) | |
986 (goto-char point) | |
987 | |
988 (if (mm-handle-displayed-p handle) | |
989 ;; This will remove the part. | |
990 (progn | |
991 ;; Delete the button and displayed part (if any) | |
992 (let ((region (get-text-property point 'mh-region))) | |
993 (when region | |
994 (when (fboundp 'remove-images) | |
995 (remove-images (car region) (cdr region)))) | |
996 (mm-display-part handle) | |
997 (when region | |
998 (delete-region (car region) (cdr region)))) | |
999 ;; Delete button (if it still remains). This happens for | |
1000 ;; externally displayed parts where the previous step does | |
1001 ;; nothing. | |
1002 (unless (eolp) | |
1003 (delete-region (point) (progn (forward-line) (point))))) | |
1004 (save-restriction | |
1005 (delete-region (point) (progn (forward-line 1) (point))) | |
1006 (narrow-to-region (point) (point)) | |
1007 ;; Maybe we need another unwind-protect here. | |
1008 (when (equal (mm-handle-media-supertype handle) "image") | |
1009 (insert "\n")) | |
1010 (when (and (not (eq (ignore-errors (mm-display-part handle)) | |
1011 'inline)) | |
1012 (equal (mm-handle-media-supertype handle) | |
1013 "image")) | |
1014 (goto-char (point-min)) | |
1015 (delete-char 1)) | |
1016 (when (equal (mm-handle-media-supertype handle) "text") | |
1017 (when (eq mh-highlight-citation-p 'gnus) | |
1018 (mh-gnus-article-highlight-citation)) | |
1019 (mh-display-smileys) | |
1020 (mh-display-emphasis)) | |
1021 (setq region (cons (progn (goto-char (point-min)) | |
1022 (point-marker)) | |
1023 (progn (goto-char (point-max)) | |
1024 (point-marker))))))) | |
1025 (when (window-live-p window) | |
1026 (select-window window)) | |
1027 (goto-char point) | |
1028 (beginning-of-line) | |
1029 (mh-insert-mime-button handle id (mm-handle-displayed-p handle)) | |
1030 (goto-char point) | |
1031 (when region | |
1032 (add-text-properties (line-beginning-position) (line-end-position) | |
1033 `(mh-region ,region))))))) | |
1034 | |
1035 ;;;###mh-autoload | |
1036 (defun mh-press-button () | |
1037 "Press MIME button. | |
1038 If the MIME part is visible then it is removed. Otherwise the part is | |
1039 displayed." | |
1040 (interactive) | |
1041 (let ((mm-inline-media-tests mh-mm-inline-media-tests) | |
1042 (data (get-text-property (point) 'mh-data)) | |
1043 (function (get-text-property (point) 'mh-callback)) | |
1044 (buffer-read-only nil) | |
1045 (folder mh-show-folder-buffer)) | |
1046 (flet ((mm-handle-set-external-undisplayer | |
1047 (handle function) | |
1048 (mh-handle-set-external-undisplayer folder handle function))) | |
1049 (when (and function (eolp)) | |
1050 (backward-char)) | |
1051 (unwind-protect (and function (funcall function data)) | |
1052 (set-buffer-modified-p nil))))) | |
1053 | |
1054 ;;;###mh-autoload | |
1055 (defun mh-push-button (event) | |
1056 "Click MIME button for EVENT. | |
1057 If the MIME part is visible then it is removed. Otherwise the part is | |
1058 displayed. This function is called when the mouse is used to click the MIME | |
1059 button." | |
1060 (interactive "e") | |
1061 (set-buffer (window-buffer (posn-window (event-start event)))) | |
1062 (select-window (posn-window (event-start event))) | |
1063 (let* ((pos (posn-point (event-start event))) | |
1064 (folder mh-show-folder-buffer) | |
1065 (mm-inline-media-tests mh-mm-inline-media-tests) | |
1066 (data (get-text-property pos 'mh-data)) | |
1067 (function (get-text-property pos 'mh-callback)) | |
1068 (buffer-read-only nil)) | |
1069 (flet ((mm-handle-set-external-undisplayer | |
1070 (handle function) | |
1071 (mh-handle-set-external-undisplayer folder handle function))) | |
1072 (goto-char pos) | |
1073 (unwind-protect (and function (funcall function data)) | |
1074 (set-buffer-modified-p nil))))) | |
1075 | |
1076 ;;;###mh-autoload | |
1077 (defun mh-mime-save-part () | |
1078 "Save MIME part at point." | |
1079 (interactive) | |
1080 (let ((data (get-text-property (point) 'mh-data))) | |
1081 (when data | |
1082 (let ((mm-default-directory mh-mime-save-parts-directory)) | |
1083 (mh-mm-save-part data) | |
1084 (setq mh-mime-save-parts-directory mm-default-directory))))) | |
1085 | |
1086 ;;;###mh-autoload | |
1087 (defun mh-mime-inline-part () | |
1088 "Toggle display of the raw MIME part." | |
1089 (interactive) | |
1090 (let* ((buffer-read-only nil) | |
1091 (data (get-text-property (point) 'mh-data)) | |
1092 (inserted-flag (get-text-property (point) 'mh-mime-inserted)) | |
1093 (displayed-flag (mm-handle-displayed-p data)) | |
1094 (point (point)) | |
1095 start end) | |
1096 (cond ((and data (not inserted-flag) (not displayed-flag)) | |
1097 (let ((contents (mm-get-part data))) | |
1098 (add-text-properties (line-beginning-position) (line-end-position) | |
1099 '(mh-mime-inserted t)) | |
1100 (setq start (point-marker)) | |
1101 (forward-line 1) | |
1102 (mm-insert-inline data contents) | |
1103 (setq end (point-marker)) | |
1104 (add-text-properties | |
1105 start (progn (goto-char start) (line-end-position)) | |
1106 `(mh-region (,start . ,end))))) | |
1107 ((and data (or inserted-flag displayed-flag)) | |
1108 (mh-press-button) | |
1109 (message "MIME part already inserted"))) | |
1110 (goto-char point) | |
1111 (set-buffer-modified-p nil))) | |
1112 | |
1113 (defun mh-widget-press-button (widget el) | |
1114 "Callback for widget, WIDGET. | |
1115 Parameter EL is unused." | |
1116 (goto-char (widget-get widget :from)) | |
1117 (mh-press-button)) | |
1118 | |
1119 (defun mh-mime-display-security (handle) | |
1120 "Display PGP encrypted/signed message, HANDLE." | |
1121 (insert "\n") | |
1122 (save-restriction | |
1123 (narrow-to-region (point) (point)) | |
1124 (mh-insert-mime-security-button handle) | |
1125 (mh-mime-display-mixed (cdr handle)) | |
1126 (insert "\n") | |
1127 (let ((mh-mime-security-button-line-format | |
1128 mh-mime-security-button-end-line-format)) | |
1129 (mh-insert-mime-security-button handle)) | |
1130 (mm-set-handle-multipart-parameter | |
1131 handle 'mh-region | |
1132 (cons (set-marker (make-marker) (point-min)) | |
1133 (set-marker (make-marker) (point-max)))))) | |
1134 | |
1135 ;;; I rewrote the security part because Gnus doesn't seem to ever minimize | |
1136 ;;; the button. That is once the mime-security button is pressed there seems | |
1137 ;;; to be no way of getting rid of the inserted text. | |
1138 (defun mh-mime-security-show-details (handle) | |
1139 "Toggle display of detailed security info for HANDLE." | |
1140 (let ((details (mm-handle-multipart-ctl-parameter handle 'gnus-details))) | |
1141 (when details | |
1142 (let ((mh-mime-security-button-pressed | |
1143 (not (get-text-property (point) 'mh-button-pressed))) | |
1144 (mh-mime-security-button-line-format | |
1145 (get-text-property (point) 'mh-line-format))) | |
1146 (forward-char -1) | |
1147 (while (eq (get-text-property (point) 'mh-line-format) | |
1148 mh-mime-security-button-line-format) | |
1149 (forward-char -1)) | |
1150 (forward-char) | |
1151 (save-restriction | |
1152 (narrow-to-region (point) (point)) | |
1153 (mh-insert-mime-security-button handle)) | |
1154 (delete-region | |
1155 (point) | |
1156 (or (text-property-not-all | |
1157 (point) (point-max) | |
1158 'mh-line-format mh-mime-security-button-line-format) | |
1159 (point-max))) | |
1160 (forward-line -1))))) | |
1161 | |
1162 (defun mh-mime-security-press-button (handle) | |
1163 "Callback from security button for part HANDLE." | |
1164 (when (mm-handle-multipart-ctl-parameter handle 'gnus-info) | |
1165 (mh-mime-security-show-details handle))) | |
1166 | |
1167 ;; These variables should already be initialized in mm-decode.el if we have a | |
1168 ;; recent enough Gnus. The defvars are here to avoid compiler warnings. | |
1169 (defvar mm-verify-function-alist nil) | |
1170 (defvar mm-decrypt-function-alist nil) | |
1171 | |
1172 (defvar pressed-details) | |
1173 | |
1174 (defun mh-insert-mime-security-button (handle) | |
1175 "Display buttons for PGP message, HANDLE." | |
1176 (let* ((protocol (mm-handle-multipart-ctl-parameter handle 'protocol)) | |
1177 (crypto-type (or (nth 2 (assoc protocol mm-verify-function-alist)) | |
1178 (nth 2 (assoc protocol mm-decrypt-function-alist)) | |
1179 "Unknown")) | |
1180 (type (concat crypto-type | |
1181 (if (equal (car handle) "multipart/signed") | |
1182 " Signed" " Encrypted") | |
1183 " Part")) | |
1184 (info (or (mm-handle-multipart-ctl-parameter handle 'gnus-info) | |
1185 "Undecided")) | |
1186 (details (mm-handle-multipart-ctl-parameter handle 'gnus-details)) | |
1187 pressed-details begin end) | |
1188 (setq details (if details (concat "\n" details) "")) | |
1189 (setq pressed-details (if mh-mime-security-button-pressed details "")) | |
1190 (unless (bolp) (insert "\n")) | |
1191 (setq begin (point)) | |
1192 (gnus-eval-format | |
1193 mh-mime-security-button-line-format | |
1194 mh-mime-security-button-line-format-alist | |
1195 `(,@(gnus-local-map-property mh-mime-security-button-map) | |
1196 mh-button-pressed ,mh-mime-security-button-pressed | |
1197 mh-callback mh-mime-security-press-button | |
1198 mh-line-format ,mh-mime-security-button-line-format | |
1199 mh-data ,handle)) | |
1200 (setq end (point)) | |
1201 (widget-convert-button 'link begin end | |
1202 :mime-handle handle | |
1203 :action 'mh-widget-press-button | |
1204 :button-keymap mh-mime-security-button-map | |
1205 :help-echo "Mouse-2 click or press RET (in show buffer) to see security details.") | |
1206 (when (equal info "Failed") | |
1207 (let* ((type (if (equal (car handle) "multipart/signed") | |
1208 "verification" "decryption")) | |
1209 (warning (if (equal type "decryption") | |
1210 "(passphrase may be incorrect)" ""))) | |
1211 (message "%s %s failed %s" crypto-type type warning))))) | |
1212 | |
1213 (defun mh-mm-inline-message (handle) | |
1214 "Display message, HANDLE. | |
1215 The function decodes the message and displays it. It avoids decoding the same | |
1216 message multiple times." | |
1217 (let ((b (point)) | |
1218 (charset (mail-content-type-get (mm-handle-type handle) 'charset)) | |
1219 (clean-message-header mh-clean-message-header-flag) | |
1220 (invisible-headers mh-invisible-headers) | |
1221 (visible-headers mh-visible-headers)) | |
1222 (when (and charset (stringp charset)) | |
1223 (setq charset (intern (downcase charset))) | |
1224 (when (eq charset 'us-ascii) | |
1225 (setq charset nil))) | |
1226 (save-excursion | |
1227 (save-restriction | |
1228 (narrow-to-region b b) | |
1229 (mm-insert-part handle) | |
1230 (mh-mime-display | |
1231 (or (gethash handle (mh-mime-handles-cache (mh-buffer-data))) | |
1232 (setf (gethash handle (mh-mime-handles-cache (mh-buffer-data))) | |
1233 (let ((handles (or (mm-dissect-buffer nil) | |
1234 (mm-uu-dissect)))) | |
1235 (setf (mh-mime-handles (mh-buffer-data)) | |
1236 (mm-merge-handles | |
1237 handles (mh-mime-handles (mh-buffer-data)))) | |
1238 handles)))) | |
1239 | |
1240 (goto-char (point-min)) | |
1241 (cond (clean-message-header | |
1242 (mh-clean-msg-header (point-min) | |
1243 invisible-headers | |
1244 visible-headers) | |
1245 (goto-char (point-min))) | |
1246 (t | |
1247 (mh-start-of-uncleaned-message))) | |
1248 (mh-show-xface) | |
1249 (mh-show-addr) | |
1250 ;; The other highlighting types don't need anything special | |
1251 (when (eq mh-highlight-citation-p 'gnus) | |
1252 (mh-gnus-article-highlight-citation)) | |
1253 (goto-char (point-min)) | |
1254 (insert "\n------- Forwarded Message\n\n") | |
1255 (mh-display-smileys) | |
1256 (mh-display-emphasis) | |
1257 (mm-handle-set-undisplayer | |
1258 handle | |
1259 `(lambda () | |
1260 (let (buffer-read-only) | |
1261 (if (fboundp 'remove-specifier) | |
1262 ;; This is only valid on XEmacs. | |
1263 (mapcar (lambda (prop) | |
1264 (remove-specifier | |
1265 (face-property 'default prop) (current-buffer))) | |
1266 '(background background-pixmap foreground))) | |
1267 (delete-region ,(point-min-marker) ,(point-max-marker))))))))) | |
1268 | |
1269 (provide 'mh-mime) | |
1270 | |
1271 ;;; Local Variables: | |
1272 ;;; indent-tabs-mode: nil | |
1273 ;;; sentence-end-double-space: nil | |
1274 ;;; End: | |
1275 | |
1276 ;;; mh-mime.el ends here |