Mercurial > emacs
diff 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 |
line wrap: on
line diff
--- a/lisp/mh-e/mh-mime.el Sat Aug 14 13:51:44 2004 +0000 +++ b/lisp/mh-e/mh-mime.el Sun Aug 15 22:00:06 2004 +0000 @@ -34,7 +34,7 @@ ;;; Code: -(require 'mh-utils) +(eval-when-compile (require 'mh-acros)) (mh-require-cl) (require 'mh-comp) (require 'gnus-util) @@ -46,8 +46,7 @@ (autoload 'gnus-eval-format "gnus-spec") (autoload 'widget-convert-button "wid-edit") (autoload 'message-options-set-recipient "message") -(autoload 'mml-secure-message-sign-pgpmime "mml-sec") -(autoload 'mml-secure-message-encrypt-pgpmime "mml-sec") +(autoload 'mml-unsecure-message "mml-sec") (autoload 'mml-minibuffer-read-file "mml") (autoload 'mml-minibuffer-read-description "mml") (autoload 'mml-insert-empty-tag "mml") @@ -82,7 +81,7 @@ (read-string "Forw Content-description: ") (mh-prompt-for-folder "Message from" mh-sent-from-folder nil) (read-string (format "Messages%s: " - (if mh-sent-from-msg + (if (numberp mh-sent-from-msg) (format " [%d]" mh-sent-from-msg) ""))))) (if (equal mh-compose-insertion 'gnus) @@ -114,6 +113,7 @@ ;; the variable, so things should work exactly as before. (defvar mh-have-file-command) +;;;###mh-autoload (defun mh-have-file-command () "Return t if 'file' command is on the system. 'file -i' is used to get MIME type of composition insertion." @@ -129,7 +129,8 @@ (defvar mh-file-mime-type-substitutions '(("application/msword" "\.xls" "application/ms-excel") - ("application/msword" "\.ppt" "application/ms-powerpoint")) + ("application/msword" "\.ppt" "application/ms-powerpoint") + ("text/plain" "\.vcf" "text/x-vcard")) "Substitutions to make for Content-Type returned from file command. The first element is the Content-Type returned by the file command. The second element is a regexp matching the file name, usually the extension. @@ -151,6 +152,7 @@ (setq subst (cdr subst)))) answer)) +;;;###mh-autoload (defun mh-file-mime-type (filename) "Return MIME type of FILENAME from file command. Returns nil if file command not on system." @@ -192,12 +194,38 @@ ("message/external-body") ("message/partial") ("message/rfc822") ("text/enriched") ("text/html") ("text/plain") ("text/rfc822-headers") - ("text/richtext") ("text/xml") + ("text/richtext") ("text/x-vcard") ("text/xml") ("video/mpeg") ("video/quicktime")) "Legal MIME content types. See documentation for \\[mh-edit-mhn].") +;; RFC 2045 - Multipurpose Internet Mail Extensions (MIME) Part One: +;; Format of Internet Message Bodies. +;; RFC 2046 - Multipurpose Internet Mail Extensions (MIME) Part Two: +;; Media Types. +;; RFC 2049 - Multipurpose Internet Mail Extensions (MIME) Part Five: +;; Conformance Criteria and Examples. +;; RFC 2017 - Definition of the URL MIME External-Body Access-Type +;; RFC 1738 - Uniform Resource Locators (URL) +(defvar mh-access-types + '(("anon-ftp") ; RFC2046 Anonymous File Transfer Protocol + ("file") ; RFC1738 Host-specific file names + ("ftp") ; RFC2046 File Transfer Protocol + ("gopher") ; RFC1738 The Gopher Protocol + ("http") ; RFC1738 Hypertext Transfer Protocol + ("local-file") ; RFC2046 Local file access + ("mail-server") ; RFC2046 mail-server Electronic mail address + ("mailto") ; RFC1738 Electronic mail address + ("news") ; RFC1738 Usenet news + ("nntp") ; RFC1738 Usenet news using NNTP access + ("propspero") ; RFC1738 Prospero Directory Service + ("telnet") ; RFC1738 Telnet + ("tftp") ; RFC2046 Trivial File Transfer Protocol + ("url") ; RFC2017 URL scheme MIME access-type Protocol + ("wais")) ; RFC1738 Wide Area Information Servers + "Legal MIME access-type values.") + ;;;###mh-autoload (defun mh-mhn-compose-insertion (filename type description attributes) "Add a directive to insert a MIME message part from a file. @@ -286,7 +314,7 @@ "type=tar; conversions=x-compress" "mode=image")) - +;;;###mh-autoload (defun mh-mhn-compose-external-type (access-type host filename type &optional description attributes extra-params @@ -301,6 +329,18 @@ EXTRA-PARAMS, and COMMENT. See also \\[mh-edit-mhn]." + (interactive (list + (completing-read "Access Type: " mh-access-types) + (read-string "Remote host: ") + (read-string "Remote url-path: ") + (completing-read "Content-Type: " + (if (fboundp 'mailcap-mime-types) + (mapcar 'list (mailcap-mime-types)) + mh-mime-content-types)) + (if current-prefix-arg (read-string "Content-description: ")) + (if current-prefix-arg (read-string "Attributes: ")) + (if current-prefix-arg (read-string "Extra Parameters: ")) + (if current-prefix-arg (read-string "Comment: ")))) (beginning-of-line) (insert "#@" type) (and attributes @@ -314,7 +354,9 @@ (insert "access-type=" access-type "; ") (insert "site=" host) (insert "; name=" (file-name-nondirectory filename)) - (insert "; directory=\"" (file-name-directory filename) "\"") + (let ((directory (file-name-directory filename))) + (and directory + (insert "; directory=\"" directory "\""))) (and extra-params (insert "; " extra-params)) (insert "\n")) @@ -332,7 +374,7 @@ (read-string "Forw Content-description: ") (mh-prompt-for-folder "Message from" mh-sent-from-folder nil) (read-string (format "Messages%s: " - (if mh-sent-from-msg + (if (numberp mh-sent-from-msg) (format " [%d]" mh-sent-from-msg) ""))))) (beginning-of-line) @@ -349,7 +391,7 @@ (let ((start (point))) (insert " " messages) (subst-char-in-region start (point) ?, ? )) - (if mh-sent-from-msg + (if (numberp mh-sent-from-msg) (insert " " (int-to-string mh-sent-from-msg)))) (insert "\n")) @@ -380,10 +422,11 @@ The mhn program is part of MH version 6.8 or later." (interactive "*P") + (mh-mhn-quote-unescaped-sharp) (save-buffer) (message "mhn editing...") (cond - (mh-nmh-flag + ((mh-variant-p 'nmh) (mh-exec-cmd-error nil "mhbuild" (if extra-args mh-mhn-args) buffer-file-name)) (t @@ -393,6 +436,19 @@ (message "mhn editing...done") (run-hooks 'mh-edit-mhn-hook)) +(defun mh-mhn-quote-unescaped-sharp () + "Quote `#' characters that haven't been quoted for `mhbuild'. +If the `#' character is present in the first column, but it isn't part of a +MHN directive then `mhbuild' gives an error. This function will quote all such +characters." + (save-excursion + (goto-char (point-min)) + (while (re-search-forward "^#" nil t) + (beginning-of-line) + (unless (mh-mhn-directive-present-p (point) (line-end-position)) + (insert "#")) + (goto-char (line-end-position))))) + ;;;###mh-autoload (defun mh-revert-mhn-edit (noconfirm) "Undo the effect of \\[mh-edit-mhn] by reverting to the backup file. @@ -422,18 +478,24 @@ (after-find-file nil))) ;;;###mh-autoload -(defun mh-mhn-directive-present-p () - "Check if the current buffer has text which might be a MHN directive." +(defun mh-mhn-directive-present-p (&optional begin end) + "Check if the text between BEGIN and END might be a MHN directive. +The optional argument BEGIN defaults to the beginning of the buffer, while END +defaults to the the end of the buffer." + (unless begin (setq begin (point-min))) + (unless end (setq end (point-max))) (save-excursion (block 'search-for-mhn-directive - (goto-char (point-min)) - (while (re-search-forward "^#" nil t) + (goto-char begin) + (while (re-search-forward "^#" end t) (let ((s (buffer-substring-no-properties (point) (line-end-position)))) (cond ((equal s "")) ((string-match "^forw[ \t\n]+" s) (return-from 'search-for-mhn-directive t)) (t (let ((first-token (car (split-string s "[ \t;@]")))) - (when (string-match mh-media-type-regexp first-token) + (when (and first-token + (string-match mh-media-type-regexp + first-token)) (return-from 'search-for-mhn-directive t))))))) nil))) @@ -450,14 +512,23 @@ (require 'message) (when mh-gnus-pgp-support-flag ;; This is only needed for PGP (message-options-set-recipient)) - (mml-to-mime)) + (let ((saved-text (buffer-string)) + (buffer (current-buffer)) + (modified-flag (buffer-modified-p))) + (condition-case err (mml-to-mime) + (error + (with-current-buffer buffer + (delete-region (point-min) (point-max)) + (insert saved-text) + (set-buffer-modified-p modified-flag)) + (error (error-message-string err)))))) ;;;###mh-autoload (defun mh-mml-forward-message (description folder message) "Forward a message as attachment. The function will prompt the user for a DESCRIPTION, a FOLDER and MESSAGE number." - (let ((msg (if (equal message "") + (let ((msg (if (and (equal message "") (numberp mh-sent-from-msg)) mh-sent-from-msg (car (read-from-string message))))) (cond ((integerp msg) @@ -473,6 +544,19 @@ description))) (t (error "The message number, %s is not a integer!" msg))))) +(defvar mh-mml-cryptographic-method-history ()) + +;;;###mh-autoload +(defun mh-mml-query-cryptographic-method () + "Read the cryptographic method to use." + (if current-prefix-arg + (let ((def (or (car mh-mml-cryptographic-method-history) + mh-mml-method-default))) + (completing-read (format "Method: [%s] " def) + '(("pgp") ("pgpmime") ("smime")) + nil t nil 'mh-mml-cryptographic-method-history def)) + mh-mml-method-default)) + ;;;###mh-autoload (defun mh-mml-attach-file (&optional disposition) "Attach a file to the outgoing MIME message. @@ -499,22 +583,56 @@ (mml-insert-empty-tag 'part 'type type 'filename file 'disposition dispos 'description description))) -;;;###mh-autoload -(defun mh-mml-secure-message-sign-pgpmime () - "Add directive to encrypt/sign the entire message." - (interactive) +(defun mh-secure-message (method mode &optional identity) + "Add directive to Encrypt/Sign an entire message. +METHOD should be one of: \"pgpmime\", \"pgp\", \"smime\". +MODE should be one of: \"sign\", \"encrypt\", \"signencrypt\", \"none\". +IDENTITY is optionally the default-user-id to use." (if (not mh-gnus-pgp-support-flag) (error "Sorry. Your version of gnus does not support PGP/GPG") - (mml-secure-message-sign-pgpmime))) + ;; Check the arguments + (let ((valid-methods (list "pgpmime" "pgp" "smime")) + (valid-modes (list "sign" "encrypt" "signencrypt" "none"))) + (if (not (member method valid-methods)) + (error (format "Sorry. METHOD \"%s\" is invalid." method))) + (if (not (member mode valid-modes)) + (error (format "Sorry. MODE \"%s\" is invalid" mode))) + (mml-unsecure-message) + (if (not (string= mode "none")) + (save-excursion + (goto-char (point-min)) + (mh-goto-header-end 1) + (if mh-identity-pgg-default-user-id + (mml-insert-tag 'secure 'method method 'mode mode + 'sender mh-identity-pgg-default-user-id) + (mml-insert-tag 'secure 'method method 'mode mode))))))) ;;;###mh-autoload -(defun mh-mml-secure-message-encrypt-pgpmime (&optional dontsign) - "Add directive to encrypt and sign the entire message. -If called with a prefix argument DONTSIGN, only encrypt (do NOT sign)." +(defun mh-mml-unsecure-message (&optional ignore) + "Remove any secure message directives. +The IGNORE argument is not used." (interactive "P") (if (not mh-gnus-pgp-support-flag) (error "Sorry. Your version of gnus does not support PGP/GPG") - (mml-secure-message-encrypt-pgpmime dontsign))) + (mml-unsecure-message))) + +;;;###mh-autoload +(defun mh-mml-secure-message-sign (method) + "Add security directive to sign the entire message using METHOD." + (interactive (list (mh-mml-query-cryptographic-method))) + (mh-secure-message method "sign" mh-identity-pgg-default-user-id)) + +;;;###mh-autoload +(defun mh-mml-secure-message-encrypt (method) + "Add security directive to encrypt the entire message using METHOD." + (interactive (list (mh-mml-query-cryptographic-method))) + (mh-secure-message method "encrypt" mh-identity-pgg-default-user-id)) + +;;;###mh-autoload +(defun mh-mml-secure-message-signencrypt (method) + "Add security directive to encrypt and sign the entire message using METHOD." + (interactive (list (mh-mml-query-cryptographic-method))) + (mh-secure-message method "signencrypt" mh-identity-pgg-default-user-id)) ;;;###mh-autoload (defun mh-mml-directive-present-p () @@ -667,19 +785,19 @@ (folder (if (eq major-mode 'mh-show-mode) mh-show-folder-buffer mh-current-folder)) - (command (if mh-nmh-flag "mhstore" "mhn")) + (command (if (mh-variant-p 'nmh) "mhstore" "mhn")) (directory (cond ((and (or arg (equal nil mh-mime-save-parts-default-directory) (equal t mh-mime-save-parts-default-directory)) (not mh-mime-save-parts-directory)) - (read-file-name "Store in what directory? " nil nil t nil)) + (read-file-name "Store in directory: " nil nil t nil)) ((and (or arg (equal t mh-mime-save-parts-default-directory)) mh-mime-save-parts-directory) (read-file-name (format - "Store in what directory? [%s] " + "Store in directory: [%s] " mh-mime-save-parts-directory) "" mh-mime-save-parts-directory t "")) ((stringp mh-mime-save-parts-default-directory) @@ -689,7 +807,7 @@ (if (and (equal directory "") mh-mime-save-parts-directory) (setq directory mh-mime-save-parts-directory)) (if (not (file-directory-p directory)) - (message "No directory specified.") + (message "No directory specified") (if (equal nil mh-mime-save-parts-default-directory) (setq mh-mime-save-parts-directory directory)) (save-excursion @@ -766,17 +884,18 @@ (mh-mime-handles (mh-buffer-data)))) (unless handles (mh-decode-message-body))) - (when (and handles - (or (not (stringp (car handles))) (cdr handles))) - ;; Goto start of message body - (goto-char (point-min)) - (or (search-forward "\n\n" nil t) (goto-char (point-max))) + (cond ((and handles + (or (not (stringp (car handles))) (cdr handles))) + ;; Goto start of message body + (goto-char (point-min)) + (or (search-forward "\n\n" nil t) (goto-char (point-max))) - ;; Delete the body - (delete-region (point) (point-max)) + ;; Delete the body + (delete-region (point) (point-max)) - ;; Display the MIME handles - (mh-mime-display-part handles))) + ;; Display the MIME handles + (mh-mime-display-part handles)) + (t (mh-signature-highlight)))) (error (message "Please report this error. The error message is:\n %s" (error-message-string err)) @@ -874,7 +993,7 @@ (save-restriction (widen) (goto-char (point-min)) - (not (re-search-forward "^-- $" nil t))))))) + (not (mh-signature-separator-p))))))) (defun mh-mime-display-single (handle) "Display a leaf node, HANDLE in the MIME tree." @@ -904,7 +1023,8 @@ (insert "\n") (mh-insert-mime-button handle (mh-mime-part-index handle) nil)) ((and displayp (not mh-display-buttons-for-inline-parts-flag)) - (or (mm-display-part handle) (mm-display-part handle))) + (or (mm-display-part handle) (mm-display-part handle)) + (mh-signature-highlight handle)) ((and displayp mh-display-buttons-for-inline-parts-flag) (insert "\n") (mh-insert-mime-button handle (mh-mime-part-index handle) nil) @@ -912,6 +1032,28 @@ (mh-mm-display-part handle))) (goto-char (point-max))))) +(defun mh-signature-highlight (&optional handle) + "Highlight message signature in HANDLE. +The optional argument, HANDLE is a MIME handle if the function is being used +to highlight the signature in a MIME part." + (let ((regexp + (cond ((not handle) "^-- $") + ((not (and (equal (mm-handle-media-supertype handle) "text") + (equal (mm-handle-media-subtype handle) "html"))) + "^-- $") + ((eq (mh-mm-text-html-renderer) 'lynx) "^ --$") + (t "^--$")))) + (save-excursion + (goto-char (point-max)) + (when (re-search-backward regexp nil t) + (mh-do-in-gnu-emacs + (let ((ov (make-overlay (point) (point-max)))) + (overlay-put ov 'face 'mh-show-signature-face) + (overlay-put ov 'evaporate t))) + (mh-do-in-xemacs + (set-extent-property (make-extent (point) (point-max)) + 'face 'mh-show-signature-face)))))) + (mh-do-in-xemacs (defvar dots) (defvar type)) @@ -954,7 +1096,9 @@ :action 'mh-widget-press-button :button-keymap mh-mime-button-map :help-echo - "Mouse-2 click or press RET (in show buffer) to toggle display"))) + "Mouse-2 click or press RET (in show buffer) to toggle display") + (dolist (ov (mh-funcall-if-exists overlays-in begin end)) + (mh-funcall-if-exists overlay-put ov 'evaporate t)))) ;; There is a bug in Gnus inline image display due to which an extra line ;; gets inserted every time it is viewed. To work around that problem we are @@ -1009,7 +1153,8 @@ (when (eq mh-highlight-citation-p 'gnus) (mh-gnus-article-highlight-citation)) (mh-display-smileys) - (mh-display-emphasis)) + (mh-display-emphasis) + (mh-signature-highlight handle)) (setq region (cons (progn (goto-char (point-min)) (point-marker)) (progn (goto-char (point-max)) @@ -1098,6 +1243,31 @@ (goto-char point) (set-buffer-modified-p nil))) +;;;###mh-autoload +(defun mh-display-with-external-viewer (part-index) + "View MIME PART-INDEX externally." + (interactive "P") + (when (consp part-index) (setq part-index (car part-index))) + (mh-folder-mime-action + part-index + #'(lambda () + (let* ((part (get-text-property (point) 'mh-data)) + (type (mm-handle-media-type part)) + (methods (mapcar (lambda (x) (list (cdr (assoc 'viewer x)))) + (mailcap-mime-info type 'all))) + (def (caar methods)) + (prompt (format "Viewer: %s" (if def (format "[%s] " def) ""))) + (method (completing-read prompt methods nil nil nil nil def)) + (folder mh-show-folder-buffer) + (buffer-read-only nil)) + (when (string-match "^[^% \t]+$" method) + (setq method (concat method " %s"))) + (flet ((mm-handle-set-external-undisplayer (handle function) + (mh-handle-set-external-undisplayer folder handle function))) + (unwind-protect (mm-display-external part method) + (set-buffer-modified-p nil))))) + nil)) + (defun mh-widget-press-button (widget el) "Callback for widget, WIDGET. Parameter EL is unused." @@ -1106,9 +1276,9 @@ (defun mh-mime-display-security (handle) "Display PGP encrypted/signed message, HANDLE." - (insert "\n") (save-restriction (narrow-to-region (point) (point)) + (insert "\n") (mh-insert-mime-security-button handle) (mh-mime-display-mixed (cdr handle)) (insert "\n") @@ -1116,9 +1286,7 @@ mh-mime-security-button-end-line-format)) (mh-insert-mime-security-button handle)) (mm-set-handle-multipart-parameter - handle 'mh-region - (cons (set-marker (make-marker) (point-min)) - (set-marker (make-marker) (point-max)))))) + handle 'mh-region (cons (point-min-marker) (point-max-marker))))) ;;; I rewrote the security part because Gnus doesn't seem to ever minimize ;;; the button. That is once the mime-security button is pressed there seems @@ -1149,8 +1317,22 @@ (defun mh-mime-security-press-button (handle) "Callback from security button for part HANDLE." - (when (mm-handle-multipart-ctl-parameter handle 'gnus-info) - (mh-mime-security-show-details handle))) + (if (mm-handle-multipart-ctl-parameter handle 'gnus-info) + (mh-mime-security-show-details handle) + (let ((region (mm-handle-multipart-ctl-parameter handle 'mh-region)) + point) + (setq point (point)) + (goto-char (car region)) + (delete-region (car region) (cdr region)) + (with-current-buffer (mm-handle-multipart-ctl-parameter handle 'buffer) + (let* ((mm-verify-option 'known) + (mm-decrypt-option 'known) + (new (mm-possibly-verify-or-decrypt (cdr handle) handle))) + (unless (eq new (cdr handle)) + (mm-destroy-parts (cdr handle)) + (setcdr handle new)))) + (mh-mime-display-security handle) + (goto-char point)))) ;; These variables should already be initialized in mm-decode.el if we have a ;; recent enough Gnus. The defvars are here to avoid compiler warnings. @@ -1191,6 +1373,8 @@ :action 'mh-widget-press-button :button-keymap mh-mime-security-button-map :help-echo "Mouse-2 click or press RET (in show buffer) to see security details.") + (dolist (ov (mh-funcall-if-exists overlays-in begin end)) + (mh-funcall-if-exists overlay-put ov 'evaporate t)) (when (equal info "Failed") (let* ((type (if (equal (car handle) "multipart/signed") "verification" "decryption")) @@ -1204,8 +1388,8 @@ message multiple times." (let ((b (point)) (clean-message-header mh-clean-message-header-flag) - (invisible-headers mh-invisible-headers) - (visible-headers mh-visible-headers)) + (invisible-headers mh-invisible-header-fields-compiled) + (visible-headers nil)) (save-excursion (save-restriction (narrow-to-region b b)