Mercurial > emacs
comparison lisp/mh-e/mh-mime.el @ 56673:e9a6cbc8ca5e
Upgraded to MH-E version 7.4.80.
See etc/MH-E-NEWS and lisp/mh-e/ChangeLog for details.
author | Bill Wohler <wohler@newt.com> |
---|---|
date | Sun, 15 Aug 2004 22:00:06 +0000 |
parents | d36b00b98db0 |
children | 72a02133177e |
comparison
equal
deleted
inserted
replaced
56672:83ab2b01744a | 56673:e9a6cbc8ca5e |
---|---|
32 | 32 |
33 ;;; Change Log: | 33 ;;; Change Log: |
34 | 34 |
35 ;;; Code: | 35 ;;; Code: |
36 | 36 |
37 (require 'mh-utils) | 37 (eval-when-compile (require 'mh-acros)) |
38 (mh-require-cl) | 38 (mh-require-cl) |
39 (require 'mh-comp) | 39 (require 'mh-comp) |
40 (require 'gnus-util) | 40 (require 'gnus-util) |
41 (require 'mh-gnus) | 41 (require 'mh-gnus) |
42 | 42 |
44 (autoload 'article-emphasize "gnus-art") | 44 (autoload 'article-emphasize "gnus-art") |
45 (autoload 'gnus-get-buffer-create "gnus") | 45 (autoload 'gnus-get-buffer-create "gnus") |
46 (autoload 'gnus-eval-format "gnus-spec") | 46 (autoload 'gnus-eval-format "gnus-spec") |
47 (autoload 'widget-convert-button "wid-edit") | 47 (autoload 'widget-convert-button "wid-edit") |
48 (autoload 'message-options-set-recipient "message") | 48 (autoload 'message-options-set-recipient "message") |
49 (autoload 'mml-secure-message-sign-pgpmime "mml-sec") | 49 (autoload 'mml-unsecure-message "mml-sec") |
50 (autoload 'mml-secure-message-encrypt-pgpmime "mml-sec") | |
51 (autoload 'mml-minibuffer-read-file "mml") | 50 (autoload 'mml-minibuffer-read-file "mml") |
52 (autoload 'mml-minibuffer-read-description "mml") | 51 (autoload 'mml-minibuffer-read-description "mml") |
53 (autoload 'mml-insert-empty-tag "mml") | 52 (autoload 'mml-insert-empty-tag "mml") |
54 (autoload 'mml-to-mime "mml") | 53 (autoload 'mml-to-mime "mml") |
55 (autoload 'mml-attach-file "mml") | 54 (autoload 'mml-attach-file "mml") |
80 If any of the optional arguments are absent, they are prompted for." | 79 If any of the optional arguments are absent, they are prompted for." |
81 (interactive (list | 80 (interactive (list |
82 (read-string "Forw Content-description: ") | 81 (read-string "Forw Content-description: ") |
83 (mh-prompt-for-folder "Message from" mh-sent-from-folder nil) | 82 (mh-prompt-for-folder "Message from" mh-sent-from-folder nil) |
84 (read-string (format "Messages%s: " | 83 (read-string (format "Messages%s: " |
85 (if mh-sent-from-msg | 84 (if (numberp mh-sent-from-msg) |
86 (format " [%d]" mh-sent-from-msg) | 85 (format " [%d]" mh-sent-from-msg) |
87 ""))))) | 86 ""))))) |
88 (if (equal mh-compose-insertion 'gnus) | 87 (if (equal mh-compose-insertion 'gnus) |
89 (mh-mml-forward-message description folder message) | 88 (mh-mml-forward-message description folder message) |
90 (mh-mhn-compose-forw description folder message))) | 89 (mh-mhn-compose-forw description folder message))) |
112 | 111 |
113 ;; Just defvar the variable to avoid compiler warning... This doesn't bind | 112 ;; Just defvar the variable to avoid compiler warning... This doesn't bind |
114 ;; the variable, so things should work exactly as before. | 113 ;; the variable, so things should work exactly as before. |
115 (defvar mh-have-file-command) | 114 (defvar mh-have-file-command) |
116 | 115 |
116 ;;;###mh-autoload | |
117 (defun mh-have-file-command () | 117 (defun mh-have-file-command () |
118 "Return t if 'file' command is on the system. | 118 "Return t if 'file' command is on the system. |
119 'file -i' is used to get MIME type of composition insertion." | 119 'file -i' is used to get MIME type of composition insertion." |
120 (when (not (boundp 'mh-have-file-command)) | 120 (when (not (boundp 'mh-have-file-command)) |
121 (load "executable" t t) ; executable-find not autoloaded in emacs20 | 121 (load "executable" t t) ; executable-find not autoloaded in emacs20 |
127 (expand-file-name "inc" mh-progs)))))) | 127 (expand-file-name "inc" mh-progs)))))) |
128 mh-have-file-command) | 128 mh-have-file-command) |
129 | 129 |
130 (defvar mh-file-mime-type-substitutions | 130 (defvar mh-file-mime-type-substitutions |
131 '(("application/msword" "\.xls" "application/ms-excel") | 131 '(("application/msword" "\.xls" "application/ms-excel") |
132 ("application/msword" "\.ppt" "application/ms-powerpoint")) | 132 ("application/msword" "\.ppt" "application/ms-powerpoint") |
133 ("text/plain" "\.vcf" "text/x-vcard")) | |
133 "Substitutions to make for Content-Type returned from file command. | 134 "Substitutions to make for Content-Type returned from file command. |
134 The first element is the Content-Type returned by the file command. | 135 The first element is the Content-Type returned by the file command. |
135 The second element is a regexp matching the file name, usually the extension. | 136 The second element is a regexp matching the file name, usually the extension. |
136 The third element is the Content-Type to replace with.") | 137 The third element is the Content-Type to replace with.") |
137 | 138 |
149 (setq answer (elt (car subst) 2) | 150 (setq answer (elt (car subst) 2) |
150 subst nil) | 151 subst nil) |
151 (setq subst (cdr subst)))) | 152 (setq subst (cdr subst)))) |
152 answer)) | 153 answer)) |
153 | 154 |
155 ;;;###mh-autoload | |
154 (defun mh-file-mime-type (filename) | 156 (defun mh-file-mime-type (filename) |
155 "Return MIME type of FILENAME from file command. | 157 "Return MIME type of FILENAME from file command. |
156 Returns nil if file command not on system." | 158 Returns nil if file command not on system." |
157 (cond | 159 (cond |
158 ((not (mh-have-file-command)) | 160 ((not (mh-have-file-command)) |
190 | 192 |
191 ("message/delivery-status") | 193 ("message/delivery-status") |
192 ("message/external-body") ("message/partial") ("message/rfc822") | 194 ("message/external-body") ("message/partial") ("message/rfc822") |
193 | 195 |
194 ("text/enriched") ("text/html") ("text/plain") ("text/rfc822-headers") | 196 ("text/enriched") ("text/html") ("text/plain") ("text/rfc822-headers") |
195 ("text/richtext") ("text/xml") | 197 ("text/richtext") ("text/x-vcard") ("text/xml") |
196 | 198 |
197 ("video/mpeg") ("video/quicktime")) | 199 ("video/mpeg") ("video/quicktime")) |
198 "Legal MIME content types. | 200 "Legal MIME content types. |
199 See documentation for \\[mh-edit-mhn].") | 201 See documentation for \\[mh-edit-mhn].") |
202 | |
203 ;; RFC 2045 - Multipurpose Internet Mail Extensions (MIME) Part One: | |
204 ;; Format of Internet Message Bodies. | |
205 ;; RFC 2046 - Multipurpose Internet Mail Extensions (MIME) Part Two: | |
206 ;; Media Types. | |
207 ;; RFC 2049 - Multipurpose Internet Mail Extensions (MIME) Part Five: | |
208 ;; Conformance Criteria and Examples. | |
209 ;; RFC 2017 - Definition of the URL MIME External-Body Access-Type | |
210 ;; RFC 1738 - Uniform Resource Locators (URL) | |
211 (defvar mh-access-types | |
212 '(("anon-ftp") ; RFC2046 Anonymous File Transfer Protocol | |
213 ("file") ; RFC1738 Host-specific file names | |
214 ("ftp") ; RFC2046 File Transfer Protocol | |
215 ("gopher") ; RFC1738 The Gopher Protocol | |
216 ("http") ; RFC1738 Hypertext Transfer Protocol | |
217 ("local-file") ; RFC2046 Local file access | |
218 ("mail-server") ; RFC2046 mail-server Electronic mail address | |
219 ("mailto") ; RFC1738 Electronic mail address | |
220 ("news") ; RFC1738 Usenet news | |
221 ("nntp") ; RFC1738 Usenet news using NNTP access | |
222 ("propspero") ; RFC1738 Prospero Directory Service | |
223 ("telnet") ; RFC1738 Telnet | |
224 ("tftp") ; RFC2046 Trivial File Transfer Protocol | |
225 ("url") ; RFC2017 URL scheme MIME access-type Protocol | |
226 ("wais")) ; RFC1738 Wide Area Information Servers | |
227 "Legal MIME access-type values.") | |
200 | 228 |
201 ;;;###mh-autoload | 229 ;;;###mh-autoload |
202 (defun mh-mhn-compose-insertion (filename type description attributes) | 230 (defun mh-mhn-compose-insertion (filename type description attributes) |
203 "Add a directive to insert a MIME message part from a file. | 231 "Add a directive to insert a MIME message part from a file. |
204 This is the typical way to insert non-text parts in a message. | 232 This is the typical way to insert non-text parts in a message. |
284 "application/octet-stream" | 312 "application/octet-stream" |
285 description | 313 description |
286 "type=tar; conversions=x-compress" | 314 "type=tar; conversions=x-compress" |
287 "mode=image")) | 315 "mode=image")) |
288 | 316 |
289 | 317 ;;;###mh-autoload |
290 (defun mh-mhn-compose-external-type (access-type host filename type | 318 (defun mh-mhn-compose-external-type (access-type host filename type |
291 &optional description | 319 &optional description |
292 attributes extra-params | 320 attributes extra-params |
293 comment) | 321 comment) |
294 "Add a directive to include a MIME reference to a remote file. | 322 "Add a directive to include a MIME reference to a remote file. |
299 file and TYPE which is the MIME Content-Type. Optional arguments include | 327 file and TYPE which is the MIME Content-Type. Optional arguments include |
300 DESCRIPTION, a line of text for the Content-description header, ATTRIBUTES, | 328 DESCRIPTION, a line of text for the Content-description header, ATTRIBUTES, |
301 EXTRA-PARAMS, and COMMENT. | 329 EXTRA-PARAMS, and COMMENT. |
302 | 330 |
303 See also \\[mh-edit-mhn]." | 331 See also \\[mh-edit-mhn]." |
332 (interactive (list | |
333 (completing-read "Access Type: " mh-access-types) | |
334 (read-string "Remote host: ") | |
335 (read-string "Remote url-path: ") | |
336 (completing-read "Content-Type: " | |
337 (if (fboundp 'mailcap-mime-types) | |
338 (mapcar 'list (mailcap-mime-types)) | |
339 mh-mime-content-types)) | |
340 (if current-prefix-arg (read-string "Content-description: ")) | |
341 (if current-prefix-arg (read-string "Attributes: ")) | |
342 (if current-prefix-arg (read-string "Extra Parameters: ")) | |
343 (if current-prefix-arg (read-string "Comment: ")))) | |
304 (beginning-of-line) | 344 (beginning-of-line) |
305 (insert "#@" type) | 345 (insert "#@" type) |
306 (and attributes | 346 (and attributes |
307 (insert "; " attributes)) | 347 (insert "; " attributes)) |
308 (and comment | 348 (and comment |
312 (insert description)) | 352 (insert description)) |
313 (insert "] ") | 353 (insert "] ") |
314 (insert "access-type=" access-type "; ") | 354 (insert "access-type=" access-type "; ") |
315 (insert "site=" host) | 355 (insert "site=" host) |
316 (insert "; name=" (file-name-nondirectory filename)) | 356 (insert "; name=" (file-name-nondirectory filename)) |
317 (insert "; directory=\"" (file-name-directory filename) "\"") | 357 (let ((directory (file-name-directory filename))) |
358 (and directory | |
359 (insert "; directory=\"" directory "\""))) | |
318 (and extra-params | 360 (and extra-params |
319 (insert "; " extra-params)) | 361 (insert "; " extra-params)) |
320 (insert "\n")) | 362 (insert "\n")) |
321 | 363 |
322 ;;;###mh-autoload | 364 ;;;###mh-autoload |
330 See also \\[mh-edit-mhn]." | 372 See also \\[mh-edit-mhn]." |
331 (interactive (list | 373 (interactive (list |
332 (read-string "Forw Content-description: ") | 374 (read-string "Forw Content-description: ") |
333 (mh-prompt-for-folder "Message from" mh-sent-from-folder nil) | 375 (mh-prompt-for-folder "Message from" mh-sent-from-folder nil) |
334 (read-string (format "Messages%s: " | 376 (read-string (format "Messages%s: " |
335 (if mh-sent-from-msg | 377 (if (numberp mh-sent-from-msg) |
336 (format " [%d]" mh-sent-from-msg) | 378 (format " [%d]" mh-sent-from-msg) |
337 ""))))) | 379 ""))))) |
338 (beginning-of-line) | 380 (beginning-of-line) |
339 (insert "#forw [") | 381 (insert "#forw [") |
340 (and description | 382 (and description |
347 (if (and messages | 389 (if (and messages |
348 (not (string= messages ""))) | 390 (not (string= messages ""))) |
349 (let ((start (point))) | 391 (let ((start (point))) |
350 (insert " " messages) | 392 (insert " " messages) |
351 (subst-char-in-region start (point) ?, ? )) | 393 (subst-char-in-region start (point) ?, ? )) |
352 (if mh-sent-from-msg | 394 (if (numberp mh-sent-from-msg) |
353 (insert " " (int-to-string mh-sent-from-msg)))) | 395 (insert " " (int-to-string mh-sent-from-msg)))) |
354 (insert "\n")) | 396 (insert "\n")) |
355 | 397 |
356 ;;;###mh-autoload | 398 ;;;###mh-autoload |
357 (defun mh-edit-mhn (&optional extra-args) | 399 (defun mh-edit-mhn (&optional extra-args) |
378 The value of `mh-edit-mhn-hook' is a list of functions to be called, with no | 420 The value of `mh-edit-mhn-hook' is a list of functions to be called, with no |
379 arguments, after performing the conversion. | 421 arguments, after performing the conversion. |
380 | 422 |
381 The mhn program is part of MH version 6.8 or later." | 423 The mhn program is part of MH version 6.8 or later." |
382 (interactive "*P") | 424 (interactive "*P") |
425 (mh-mhn-quote-unescaped-sharp) | |
383 (save-buffer) | 426 (save-buffer) |
384 (message "mhn editing...") | 427 (message "mhn editing...") |
385 (cond | 428 (cond |
386 (mh-nmh-flag | 429 ((mh-variant-p 'nmh) |
387 (mh-exec-cmd-error nil | 430 (mh-exec-cmd-error nil |
388 "mhbuild" (if extra-args mh-mhn-args) buffer-file-name)) | 431 "mhbuild" (if extra-args mh-mhn-args) buffer-file-name)) |
389 (t | 432 (t |
390 (mh-exec-cmd-error (format "mhdraft=%s" buffer-file-name) | 433 (mh-exec-cmd-error (format "mhdraft=%s" buffer-file-name) |
391 "mhn" (if extra-args mh-mhn-args) buffer-file-name))) | 434 "mhn" (if extra-args mh-mhn-args) buffer-file-name))) |
392 (revert-buffer t t) | 435 (revert-buffer t t) |
393 (message "mhn editing...done") | 436 (message "mhn editing...done") |
394 (run-hooks 'mh-edit-mhn-hook)) | 437 (run-hooks 'mh-edit-mhn-hook)) |
438 | |
439 (defun mh-mhn-quote-unescaped-sharp () | |
440 "Quote `#' characters that haven't been quoted for `mhbuild'. | |
441 If the `#' character is present in the first column, but it isn't part of a | |
442 MHN directive then `mhbuild' gives an error. This function will quote all such | |
443 characters." | |
444 (save-excursion | |
445 (goto-char (point-min)) | |
446 (while (re-search-forward "^#" nil t) | |
447 (beginning-of-line) | |
448 (unless (mh-mhn-directive-present-p (point) (line-end-position)) | |
449 (insert "#")) | |
450 (goto-char (line-end-position))))) | |
395 | 451 |
396 ;;;###mh-autoload | 452 ;;;###mh-autoload |
397 (defun mh-revert-mhn-edit (noconfirm) | 453 (defun mh-revert-mhn-edit (noconfirm) |
398 "Undo the effect of \\[mh-edit-mhn] by reverting to the backup file. | 454 "Undo the effect of \\[mh-edit-mhn] by reverting to the backup file. |
399 Optional non-nil argument NOCONFIRM means don't ask for confirmation." | 455 Optional non-nil argument NOCONFIRM means don't ask for confirmation." |
420 (erase-buffer) | 476 (erase-buffer) |
421 (insert-file-contents backup-file)) | 477 (insert-file-contents backup-file)) |
422 (after-find-file nil))) | 478 (after-find-file nil))) |
423 | 479 |
424 ;;;###mh-autoload | 480 ;;;###mh-autoload |
425 (defun mh-mhn-directive-present-p () | 481 (defun mh-mhn-directive-present-p (&optional begin end) |
426 "Check if the current buffer has text which might be a MHN directive." | 482 "Check if the text between BEGIN and END might be a MHN directive. |
483 The optional argument BEGIN defaults to the beginning of the buffer, while END | |
484 defaults to the the end of the buffer." | |
485 (unless begin (setq begin (point-min))) | |
486 (unless end (setq end (point-max))) | |
427 (save-excursion | 487 (save-excursion |
428 (block 'search-for-mhn-directive | 488 (block 'search-for-mhn-directive |
429 (goto-char (point-min)) | 489 (goto-char begin) |
430 (while (re-search-forward "^#" nil t) | 490 (while (re-search-forward "^#" end t) |
431 (let ((s (buffer-substring-no-properties (point) (line-end-position)))) | 491 (let ((s (buffer-substring-no-properties (point) (line-end-position)))) |
432 (cond ((equal s "")) | 492 (cond ((equal s "")) |
433 ((string-match "^forw[ \t\n]+" s) | 493 ((string-match "^forw[ \t\n]+" s) |
434 (return-from 'search-for-mhn-directive t)) | 494 (return-from 'search-for-mhn-directive t)) |
435 (t (let ((first-token (car (split-string s "[ \t;@]")))) | 495 (t (let ((first-token (car (split-string s "[ \t;@]")))) |
436 (when (string-match mh-media-type-regexp first-token) | 496 (when (and first-token |
497 (string-match mh-media-type-regexp | |
498 first-token)) | |
437 (return-from 'search-for-mhn-directive t))))))) | 499 (return-from 'search-for-mhn-directive t))))))) |
438 nil))) | 500 nil))) |
439 | 501 |
440 | 502 |
441 | 503 |
448 function may be called manually before sending the draft as well." | 510 function may be called manually before sending the draft as well." |
449 (interactive) | 511 (interactive) |
450 (require 'message) | 512 (require 'message) |
451 (when mh-gnus-pgp-support-flag ;; This is only needed for PGP | 513 (when mh-gnus-pgp-support-flag ;; This is only needed for PGP |
452 (message-options-set-recipient)) | 514 (message-options-set-recipient)) |
453 (mml-to-mime)) | 515 (let ((saved-text (buffer-string)) |
516 (buffer (current-buffer)) | |
517 (modified-flag (buffer-modified-p))) | |
518 (condition-case err (mml-to-mime) | |
519 (error | |
520 (with-current-buffer buffer | |
521 (delete-region (point-min) (point-max)) | |
522 (insert saved-text) | |
523 (set-buffer-modified-p modified-flag)) | |
524 (error (error-message-string err)))))) | |
454 | 525 |
455 ;;;###mh-autoload | 526 ;;;###mh-autoload |
456 (defun mh-mml-forward-message (description folder message) | 527 (defun mh-mml-forward-message (description folder message) |
457 "Forward a message as attachment. | 528 "Forward a message as attachment. |
458 The function will prompt the user for a DESCRIPTION, a FOLDER and MESSAGE | 529 The function will prompt the user for a DESCRIPTION, a FOLDER and MESSAGE |
459 number." | 530 number." |
460 (let ((msg (if (equal message "") | 531 (let ((msg (if (and (equal message "") (numberp mh-sent-from-msg)) |
461 mh-sent-from-msg | 532 mh-sent-from-msg |
462 (car (read-from-string message))))) | 533 (car (read-from-string message))))) |
463 (cond ((integerp msg) | 534 (cond ((integerp msg) |
464 (if (string= "" description) | 535 (if (string= "" description) |
465 ;; Rationale: mml-attach-file constructs a malformed composition | 536 ;; Rationale: mml-attach-file constructs a malformed composition |
470 (mml-attach-file (format "%s%s/%d" | 541 (mml-attach-file (format "%s%s/%d" |
471 mh-user-path (substring folder 1) msg) | 542 mh-user-path (substring folder 1) msg) |
472 "message/rfc822" | 543 "message/rfc822" |
473 description))) | 544 description))) |
474 (t (error "The message number, %s is not a integer!" msg))))) | 545 (t (error "The message number, %s is not a integer!" msg))))) |
546 | |
547 (defvar mh-mml-cryptographic-method-history ()) | |
548 | |
549 ;;;###mh-autoload | |
550 (defun mh-mml-query-cryptographic-method () | |
551 "Read the cryptographic method to use." | |
552 (if current-prefix-arg | |
553 (let ((def (or (car mh-mml-cryptographic-method-history) | |
554 mh-mml-method-default))) | |
555 (completing-read (format "Method: [%s] " def) | |
556 '(("pgp") ("pgpmime") ("smime")) | |
557 nil t nil 'mh-mml-cryptographic-method-history def)) | |
558 mh-mml-method-default)) | |
475 | 559 |
476 ;;;###mh-autoload | 560 ;;;###mh-autoload |
477 (defun mh-mml-attach-file (&optional disposition) | 561 (defun mh-mml-attach-file (&optional disposition) |
478 "Attach a file to the outgoing MIME message. | 562 "Attach a file to the outgoing MIME message. |
479 The file is not inserted or encoded until you send the message with | 563 The file is not inserted or encoded until you send the message with |
497 nil t nil nil | 581 nil t nil nil |
498 "attachment")))) | 582 "attachment")))) |
499 (mml-insert-empty-tag 'part 'type type 'filename file | 583 (mml-insert-empty-tag 'part 'type type 'filename file |
500 'disposition dispos 'description description))) | 584 'disposition dispos 'description description))) |
501 | 585 |
502 ;;;###mh-autoload | 586 (defun mh-secure-message (method mode &optional identity) |
503 (defun mh-mml-secure-message-sign-pgpmime () | 587 "Add directive to Encrypt/Sign an entire message. |
504 "Add directive to encrypt/sign the entire message." | 588 METHOD should be one of: \"pgpmime\", \"pgp\", \"smime\". |
505 (interactive) | 589 MODE should be one of: \"sign\", \"encrypt\", \"signencrypt\", \"none\". |
590 IDENTITY is optionally the default-user-id to use." | |
506 (if (not mh-gnus-pgp-support-flag) | 591 (if (not mh-gnus-pgp-support-flag) |
507 (error "Sorry. Your version of gnus does not support PGP/GPG") | 592 (error "Sorry. Your version of gnus does not support PGP/GPG") |
508 (mml-secure-message-sign-pgpmime))) | 593 ;; Check the arguments |
509 | 594 (let ((valid-methods (list "pgpmime" "pgp" "smime")) |
510 ;;;###mh-autoload | 595 (valid-modes (list "sign" "encrypt" "signencrypt" "none"))) |
511 (defun mh-mml-secure-message-encrypt-pgpmime (&optional dontsign) | 596 (if (not (member method valid-methods)) |
512 "Add directive to encrypt and sign the entire message. | 597 (error (format "Sorry. METHOD \"%s\" is invalid." method))) |
513 If called with a prefix argument DONTSIGN, only encrypt (do NOT sign)." | 598 (if (not (member mode valid-modes)) |
599 (error (format "Sorry. MODE \"%s\" is invalid" mode))) | |
600 (mml-unsecure-message) | |
601 (if (not (string= mode "none")) | |
602 (save-excursion | |
603 (goto-char (point-min)) | |
604 (mh-goto-header-end 1) | |
605 (if mh-identity-pgg-default-user-id | |
606 (mml-insert-tag 'secure 'method method 'mode mode | |
607 'sender mh-identity-pgg-default-user-id) | |
608 (mml-insert-tag 'secure 'method method 'mode mode))))))) | |
609 | |
610 ;;;###mh-autoload | |
611 (defun mh-mml-unsecure-message (&optional ignore) | |
612 "Remove any secure message directives. | |
613 The IGNORE argument is not used." | |
514 (interactive "P") | 614 (interactive "P") |
515 (if (not mh-gnus-pgp-support-flag) | 615 (if (not mh-gnus-pgp-support-flag) |
516 (error "Sorry. Your version of gnus does not support PGP/GPG") | 616 (error "Sorry. Your version of gnus does not support PGP/GPG") |
517 (mml-secure-message-encrypt-pgpmime dontsign))) | 617 (mml-unsecure-message))) |
618 | |
619 ;;;###mh-autoload | |
620 (defun mh-mml-secure-message-sign (method) | |
621 "Add security directive to sign the entire message using METHOD." | |
622 (interactive (list (mh-mml-query-cryptographic-method))) | |
623 (mh-secure-message method "sign" mh-identity-pgg-default-user-id)) | |
624 | |
625 ;;;###mh-autoload | |
626 (defun mh-mml-secure-message-encrypt (method) | |
627 "Add security directive to encrypt the entire message using METHOD." | |
628 (interactive (list (mh-mml-query-cryptographic-method))) | |
629 (mh-secure-message method "encrypt" mh-identity-pgg-default-user-id)) | |
630 | |
631 ;;;###mh-autoload | |
632 (defun mh-mml-secure-message-signencrypt (method) | |
633 "Add security directive to encrypt and sign the entire message using METHOD." | |
634 (interactive (list (mh-mml-query-cryptographic-method))) | |
635 (mh-secure-message method "signencrypt" mh-identity-pgg-default-user-id)) | |
518 | 636 |
519 ;;;###mh-autoload | 637 ;;;###mh-autoload |
520 (defun mh-mml-directive-present-p () | 638 (defun mh-mml-directive-present-p () |
521 "Check if the current buffer has text which may be an MML directive." | 639 "Check if the current buffer has text which may be an MML directive." |
522 (save-excursion | 640 (save-excursion |
665 (mh-show-buffer-message-number) | 783 (mh-show-buffer-message-number) |
666 (mh-get-msg-num t))) | 784 (mh-get-msg-num t))) |
667 (folder (if (eq major-mode 'mh-show-mode) | 785 (folder (if (eq major-mode 'mh-show-mode) |
668 mh-show-folder-buffer | 786 mh-show-folder-buffer |
669 mh-current-folder)) | 787 mh-current-folder)) |
670 (command (if mh-nmh-flag "mhstore" "mhn")) | 788 (command (if (mh-variant-p 'nmh) "mhstore" "mhn")) |
671 (directory | 789 (directory |
672 (cond | 790 (cond |
673 ((and (or arg | 791 ((and (or arg |
674 (equal nil mh-mime-save-parts-default-directory) | 792 (equal nil mh-mime-save-parts-default-directory) |
675 (equal t mh-mime-save-parts-default-directory)) | 793 (equal t mh-mime-save-parts-default-directory)) |
676 (not mh-mime-save-parts-directory)) | 794 (not mh-mime-save-parts-directory)) |
677 (read-file-name "Store in what directory? " nil nil t nil)) | 795 (read-file-name "Store in directory: " nil nil t nil)) |
678 ((and (or arg | 796 ((and (or arg |
679 (equal t mh-mime-save-parts-default-directory)) | 797 (equal t mh-mime-save-parts-default-directory)) |
680 mh-mime-save-parts-directory) | 798 mh-mime-save-parts-directory) |
681 (read-file-name (format | 799 (read-file-name (format |
682 "Store in what directory? [%s] " | 800 "Store in directory: [%s] " |
683 mh-mime-save-parts-directory) | 801 mh-mime-save-parts-directory) |
684 "" mh-mime-save-parts-directory t "")) | 802 "" mh-mime-save-parts-directory t "")) |
685 ((stringp mh-mime-save-parts-default-directory) | 803 ((stringp mh-mime-save-parts-default-directory) |
686 mh-mime-save-parts-default-directory) | 804 mh-mime-save-parts-default-directory) |
687 (t | 805 (t |
688 mh-mime-save-parts-directory)))) | 806 mh-mime-save-parts-directory)))) |
689 (if (and (equal directory "") mh-mime-save-parts-directory) | 807 (if (and (equal directory "") mh-mime-save-parts-directory) |
690 (setq directory mh-mime-save-parts-directory)) | 808 (setq directory mh-mime-save-parts-directory)) |
691 (if (not (file-directory-p directory)) | 809 (if (not (file-directory-p directory)) |
692 (message "No directory specified.") | 810 (message "No directory specified") |
693 (if (equal nil mh-mime-save-parts-default-directory) | 811 (if (equal nil mh-mime-save-parts-default-directory) |
694 (setq mh-mime-save-parts-directory directory)) | 812 (setq mh-mime-save-parts-directory directory)) |
695 (save-excursion | 813 (save-excursion |
696 (set-buffer (get-buffer-create mh-log-buffer)) | 814 (set-buffer (get-buffer-create mh-log-buffer)) |
697 (cd directory) | 815 (cd directory) |
764 (setf (mh-mime-handles (mh-buffer-data)) | 882 (setf (mh-mime-handles (mh-buffer-data)) |
765 (mm-merge-handles handles | 883 (mm-merge-handles handles |
766 (mh-mime-handles (mh-buffer-data)))) | 884 (mh-mime-handles (mh-buffer-data)))) |
767 (unless handles (mh-decode-message-body))) | 885 (unless handles (mh-decode-message-body))) |
768 | 886 |
769 (when (and handles | 887 (cond ((and handles |
770 (or (not (stringp (car handles))) (cdr handles))) | 888 (or (not (stringp (car handles))) (cdr handles))) |
771 ;; Goto start of message body | 889 ;; Goto start of message body |
772 (goto-char (point-min)) | 890 (goto-char (point-min)) |
773 (or (search-forward "\n\n" nil t) (goto-char (point-max))) | 891 (or (search-forward "\n\n" nil t) (goto-char (point-max))) |
774 | 892 |
775 ;; Delete the body | 893 ;; Delete the body |
776 (delete-region (point) (point-max)) | 894 (delete-region (point) (point-max)) |
777 | 895 |
778 ;; Display the MIME handles | 896 ;; Display the MIME handles |
779 (mh-mime-display-part handles))) | 897 (mh-mime-display-part handles)) |
898 (t (mh-signature-highlight)))) | |
780 (error | 899 (error |
781 (message "Please report this error. The error message is:\n %s" | 900 (message "Please report this error. The error message is:\n %s" |
782 (error-message-string err)) | 901 (error-message-string err)) |
783 (delete-region (point-min) (point-max)) | 902 (delete-region (point-min) (point-max)) |
784 (insert raw-message-data)))))) | 903 (insert raw-message-data)))))) |
872 (equal (car type) "text/x-vcard") | 991 (equal (car type) "text/x-vcard") |
873 (save-excursion | 992 (save-excursion |
874 (save-restriction | 993 (save-restriction |
875 (widen) | 994 (widen) |
876 (goto-char (point-min)) | 995 (goto-char (point-min)) |
877 (not (re-search-forward "^-- $" nil t))))))) | 996 (not (mh-signature-separator-p))))))) |
878 | 997 |
879 (defun mh-mime-display-single (handle) | 998 (defun mh-mime-display-single (handle) |
880 "Display a leaf node, HANDLE in the MIME tree." | 999 "Display a leaf node, HANDLE in the MIME tree." |
881 (let* ((type (mm-handle-media-type handle)) | 1000 (let* ((type (mm-handle-media-type handle)) |
882 (small-image-flag (mh-small-image-p handle)) | 1001 (small-image-flag (mh-small-image-p handle)) |
902 nil) ; skip signatures as they are already handled... | 1021 nil) ; skip signatures as they are already handled... |
903 ((not displayp) | 1022 ((not displayp) |
904 (insert "\n") | 1023 (insert "\n") |
905 (mh-insert-mime-button handle (mh-mime-part-index handle) nil)) | 1024 (mh-insert-mime-button handle (mh-mime-part-index handle) nil)) |
906 ((and displayp (not mh-display-buttons-for-inline-parts-flag)) | 1025 ((and displayp (not mh-display-buttons-for-inline-parts-flag)) |
907 (or (mm-display-part handle) (mm-display-part handle))) | 1026 (or (mm-display-part handle) (mm-display-part handle)) |
1027 (mh-signature-highlight handle)) | |
908 ((and displayp mh-display-buttons-for-inline-parts-flag) | 1028 ((and displayp mh-display-buttons-for-inline-parts-flag) |
909 (insert "\n") | 1029 (insert "\n") |
910 (mh-insert-mime-button handle (mh-mime-part-index handle) nil) | 1030 (mh-insert-mime-button handle (mh-mime-part-index handle) nil) |
911 (forward-line -1) | 1031 (forward-line -1) |
912 (mh-mm-display-part handle))) | 1032 (mh-mm-display-part handle))) |
913 (goto-char (point-max))))) | 1033 (goto-char (point-max))))) |
1034 | |
1035 (defun mh-signature-highlight (&optional handle) | |
1036 "Highlight message signature in HANDLE. | |
1037 The optional argument, HANDLE is a MIME handle if the function is being used | |
1038 to highlight the signature in a MIME part." | |
1039 (let ((regexp | |
1040 (cond ((not handle) "^-- $") | |
1041 ((not (and (equal (mm-handle-media-supertype handle) "text") | |
1042 (equal (mm-handle-media-subtype handle) "html"))) | |
1043 "^-- $") | |
1044 ((eq (mh-mm-text-html-renderer) 'lynx) "^ --$") | |
1045 (t "^--$")))) | |
1046 (save-excursion | |
1047 (goto-char (point-max)) | |
1048 (when (re-search-backward regexp nil t) | |
1049 (mh-do-in-gnu-emacs | |
1050 (let ((ov (make-overlay (point) (point-max)))) | |
1051 (overlay-put ov 'face 'mh-show-signature-face) | |
1052 (overlay-put ov 'evaporate t))) | |
1053 (mh-do-in-xemacs | |
1054 (set-extent-property (make-extent (point) (point-max)) | |
1055 'face 'mh-show-signature-face)))))) | |
914 | 1056 |
915 (mh-do-in-xemacs | 1057 (mh-do-in-xemacs |
916 (defvar dots) | 1058 (defvar dots) |
917 (defvar type)) | 1059 (defvar type)) |
918 | 1060 |
952 'link begin end | 1094 'link begin end |
953 :mime-handle handle | 1095 :mime-handle handle |
954 :action 'mh-widget-press-button | 1096 :action 'mh-widget-press-button |
955 :button-keymap mh-mime-button-map | 1097 :button-keymap mh-mime-button-map |
956 :help-echo | 1098 :help-echo |
957 "Mouse-2 click or press RET (in show buffer) to toggle display"))) | 1099 "Mouse-2 click or press RET (in show buffer) to toggle display") |
1100 (dolist (ov (mh-funcall-if-exists overlays-in begin end)) | |
1101 (mh-funcall-if-exists overlay-put ov 'evaporate t)))) | |
958 | 1102 |
959 ;; There is a bug in Gnus inline image display due to which an extra line | 1103 ;; There is a bug in Gnus inline image display due to which an extra line |
960 ;; gets inserted every time it is viewed. To work around that problem we are | 1104 ;; gets inserted every time it is viewed. To work around that problem we are |
961 ;; using an extra property 'mh-region to remember the region that is added | 1105 ;; using an extra property 'mh-region to remember the region that is added |
962 ;; when the button is clicked. The region is then deleted to make sure that | 1106 ;; when the button is clicked. The region is then deleted to make sure that |
1007 (delete-char 1)) | 1151 (delete-char 1)) |
1008 (when (equal (mm-handle-media-supertype handle) "text") | 1152 (when (equal (mm-handle-media-supertype handle) "text") |
1009 (when (eq mh-highlight-citation-p 'gnus) | 1153 (when (eq mh-highlight-citation-p 'gnus) |
1010 (mh-gnus-article-highlight-citation)) | 1154 (mh-gnus-article-highlight-citation)) |
1011 (mh-display-smileys) | 1155 (mh-display-smileys) |
1012 (mh-display-emphasis)) | 1156 (mh-display-emphasis) |
1157 (mh-signature-highlight handle)) | |
1013 (setq region (cons (progn (goto-char (point-min)) | 1158 (setq region (cons (progn (goto-char (point-min)) |
1014 (point-marker)) | 1159 (point-marker)) |
1015 (progn (goto-char (point-max)) | 1160 (progn (goto-char (point-max)) |
1016 (point-marker))))))) | 1161 (point-marker))))))) |
1017 (when (window-live-p window) | 1162 (when (window-live-p window) |
1096 (mh-press-button) | 1241 (mh-press-button) |
1097 (message "MIME part already inserted"))) | 1242 (message "MIME part already inserted"))) |
1098 (goto-char point) | 1243 (goto-char point) |
1099 (set-buffer-modified-p nil))) | 1244 (set-buffer-modified-p nil))) |
1100 | 1245 |
1246 ;;;###mh-autoload | |
1247 (defun mh-display-with-external-viewer (part-index) | |
1248 "View MIME PART-INDEX externally." | |
1249 (interactive "P") | |
1250 (when (consp part-index) (setq part-index (car part-index))) | |
1251 (mh-folder-mime-action | |
1252 part-index | |
1253 #'(lambda () | |
1254 (let* ((part (get-text-property (point) 'mh-data)) | |
1255 (type (mm-handle-media-type part)) | |
1256 (methods (mapcar (lambda (x) (list (cdr (assoc 'viewer x)))) | |
1257 (mailcap-mime-info type 'all))) | |
1258 (def (caar methods)) | |
1259 (prompt (format "Viewer: %s" (if def (format "[%s] " def) ""))) | |
1260 (method (completing-read prompt methods nil nil nil nil def)) | |
1261 (folder mh-show-folder-buffer) | |
1262 (buffer-read-only nil)) | |
1263 (when (string-match "^[^% \t]+$" method) | |
1264 (setq method (concat method " %s"))) | |
1265 (flet ((mm-handle-set-external-undisplayer (handle function) | |
1266 (mh-handle-set-external-undisplayer folder handle function))) | |
1267 (unwind-protect (mm-display-external part method) | |
1268 (set-buffer-modified-p nil))))) | |
1269 nil)) | |
1270 | |
1101 (defun mh-widget-press-button (widget el) | 1271 (defun mh-widget-press-button (widget el) |
1102 "Callback for widget, WIDGET. | 1272 "Callback for widget, WIDGET. |
1103 Parameter EL is unused." | 1273 Parameter EL is unused." |
1104 (goto-char (widget-get widget :from)) | 1274 (goto-char (widget-get widget :from)) |
1105 (mh-press-button)) | 1275 (mh-press-button)) |
1106 | 1276 |
1107 (defun mh-mime-display-security (handle) | 1277 (defun mh-mime-display-security (handle) |
1108 "Display PGP encrypted/signed message, HANDLE." | 1278 "Display PGP encrypted/signed message, HANDLE." |
1109 (insert "\n") | |
1110 (save-restriction | 1279 (save-restriction |
1111 (narrow-to-region (point) (point)) | 1280 (narrow-to-region (point) (point)) |
1281 (insert "\n") | |
1112 (mh-insert-mime-security-button handle) | 1282 (mh-insert-mime-security-button handle) |
1113 (mh-mime-display-mixed (cdr handle)) | 1283 (mh-mime-display-mixed (cdr handle)) |
1114 (insert "\n") | 1284 (insert "\n") |
1115 (let ((mh-mime-security-button-line-format | 1285 (let ((mh-mime-security-button-line-format |
1116 mh-mime-security-button-end-line-format)) | 1286 mh-mime-security-button-end-line-format)) |
1117 (mh-insert-mime-security-button handle)) | 1287 (mh-insert-mime-security-button handle)) |
1118 (mm-set-handle-multipart-parameter | 1288 (mm-set-handle-multipart-parameter |
1119 handle 'mh-region | 1289 handle 'mh-region (cons (point-min-marker) (point-max-marker))))) |
1120 (cons (set-marker (make-marker) (point-min)) | |
1121 (set-marker (make-marker) (point-max)))))) | |
1122 | 1290 |
1123 ;;; I rewrote the security part because Gnus doesn't seem to ever minimize | 1291 ;;; I rewrote the security part because Gnus doesn't seem to ever minimize |
1124 ;;; the button. That is once the mime-security button is pressed there seems | 1292 ;;; the button. That is once the mime-security button is pressed there seems |
1125 ;;; to be no way of getting rid of the inserted text. | 1293 ;;; to be no way of getting rid of the inserted text. |
1126 (defun mh-mime-security-show-details (handle) | 1294 (defun mh-mime-security-show-details (handle) |
1147 (point-max))) | 1315 (point-max))) |
1148 (forward-line -1))))) | 1316 (forward-line -1))))) |
1149 | 1317 |
1150 (defun mh-mime-security-press-button (handle) | 1318 (defun mh-mime-security-press-button (handle) |
1151 "Callback from security button for part HANDLE." | 1319 "Callback from security button for part HANDLE." |
1152 (when (mm-handle-multipart-ctl-parameter handle 'gnus-info) | 1320 (if (mm-handle-multipart-ctl-parameter handle 'gnus-info) |
1153 (mh-mime-security-show-details handle))) | 1321 (mh-mime-security-show-details handle) |
1322 (let ((region (mm-handle-multipart-ctl-parameter handle 'mh-region)) | |
1323 point) | |
1324 (setq point (point)) | |
1325 (goto-char (car region)) | |
1326 (delete-region (car region) (cdr region)) | |
1327 (with-current-buffer (mm-handle-multipart-ctl-parameter handle 'buffer) | |
1328 (let* ((mm-verify-option 'known) | |
1329 (mm-decrypt-option 'known) | |
1330 (new (mm-possibly-verify-or-decrypt (cdr handle) handle))) | |
1331 (unless (eq new (cdr handle)) | |
1332 (mm-destroy-parts (cdr handle)) | |
1333 (setcdr handle new)))) | |
1334 (mh-mime-display-security handle) | |
1335 (goto-char point)))) | |
1154 | 1336 |
1155 ;; These variables should already be initialized in mm-decode.el if we have a | 1337 ;; These variables should already be initialized in mm-decode.el if we have a |
1156 ;; recent enough Gnus. The defvars are here to avoid compiler warnings. | 1338 ;; recent enough Gnus. The defvars are here to avoid compiler warnings. |
1157 (defvar mm-verify-function-alist nil) | 1339 (defvar mm-verify-function-alist nil) |
1158 (defvar mm-decrypt-function-alist nil) | 1340 (defvar mm-decrypt-function-alist nil) |
1189 (widget-convert-button 'link begin end | 1371 (widget-convert-button 'link begin end |
1190 :mime-handle handle | 1372 :mime-handle handle |
1191 :action 'mh-widget-press-button | 1373 :action 'mh-widget-press-button |
1192 :button-keymap mh-mime-security-button-map | 1374 :button-keymap mh-mime-security-button-map |
1193 :help-echo "Mouse-2 click or press RET (in show buffer) to see security details.") | 1375 :help-echo "Mouse-2 click or press RET (in show buffer) to see security details.") |
1376 (dolist (ov (mh-funcall-if-exists overlays-in begin end)) | |
1377 (mh-funcall-if-exists overlay-put ov 'evaporate t)) | |
1194 (when (equal info "Failed") | 1378 (when (equal info "Failed") |
1195 (let* ((type (if (equal (car handle) "multipart/signed") | 1379 (let* ((type (if (equal (car handle) "multipart/signed") |
1196 "verification" "decryption")) | 1380 "verification" "decryption")) |
1197 (warning (if (equal type "decryption") | 1381 (warning (if (equal type "decryption") |
1198 "(passphrase may be incorrect)" ""))) | 1382 "(passphrase may be incorrect)" ""))) |
1202 "Display message, HANDLE. | 1386 "Display message, HANDLE. |
1203 The function decodes the message and displays it. It avoids decoding the same | 1387 The function decodes the message and displays it. It avoids decoding the same |
1204 message multiple times." | 1388 message multiple times." |
1205 (let ((b (point)) | 1389 (let ((b (point)) |
1206 (clean-message-header mh-clean-message-header-flag) | 1390 (clean-message-header mh-clean-message-header-flag) |
1207 (invisible-headers mh-invisible-headers) | 1391 (invisible-headers mh-invisible-header-fields-compiled) |
1208 (visible-headers mh-visible-headers)) | 1392 (visible-headers nil)) |
1209 (save-excursion | 1393 (save-excursion |
1210 (save-restriction | 1394 (save-restriction |
1211 (narrow-to-region b b) | 1395 (narrow-to-region b b) |
1212 (mm-insert-part handle) | 1396 (mm-insert-part handle) |
1213 (mh-mime-display | 1397 (mh-mime-display |