;;; Code:
-(require 'mh-utils)
+(eval-when-compile (require 'mh-acros))
(mh-require-cl)
(require 'mh-comp)
(require 'gnus-util)
(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")
(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)
;; 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."
(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.
(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."
("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.
"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
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
(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"))
(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)
(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"))
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
(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.
(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)))
(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)
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.
(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 ()
(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)
(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
(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))
(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."
(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)
(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))
: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
(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))
(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."
(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")
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
(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.
: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"))
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)
HCoop / bpt / emacs.git / blobdiff