;;; mh-mime.el --- MH-E support for composing MIME messages
-;; Copyright (C) 1993, 1995, 2001, 02, 2003 Free Software Foundation, Inc.
+;; Copyright (C) 1993, 1995, 2001, 02, 03, 2004 Free Software Foundation, Inc.
;; Author: Bill Wohler <wohler@newt.com>
;; Maintainer: Bill Wohler <wohler@newt.com>
;;; Code:
-(require 'cl)
+(eval-when-compile (require 'mh-acros))
+(mh-require-cl)
(require 'mh-comp)
-(require 'mh-utils)
-(load "mm-decode" t t) ; Non-fatal dependency
-(load "mm-uu" t t) ; Non-fatal dependency
-(load "mailcap" t t) ; Non-fatal dependency
-(load "smiley" t t) ; Non-fatal dependency
(require 'gnus-util)
+(require 'mh-gnus)
(autoload 'gnus-article-goto-header "gnus-art")
(autoload 'article-emphasize "gnus-art")
(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)))
This step is performed automatically when sending the message, but this
function may be called manually before sending the draft as well."
(interactive)
+ (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 ()
\f
-;;; MIME decoding
-
-(defmacro mh-defun-compat (function arg-list &rest body)
- "This is a macro to define functions which are not defined.
-It is used for Gnus utility functions which were added recently. If FUNCTION
-is not defined then it is defined to have argument list, ARG-LIST and body,
-BODY."
- (let ((defined-p (fboundp function)))
- (unless defined-p
- `(defun ,function ,arg-list ,@body))))
-(put 'mh-defun-compat 'lisp-indent-function 'defun)
-
-;; Copy of original function from gnus-util.el
-(mh-defun-compat gnus-local-map-property (map)
- "Return a list suitable for a text property list specifying keymap MAP."
- (cond (mh-xemacs-flag (list 'keymap map))
- ((>= emacs-major-version 21) (list 'keymap map))
- (t (list 'local-map map))))
-
-;; Copy of original function from mm-decode.el
-(mh-defun-compat mm-merge-handles (handles1 handles2)
- (append (if (listp (car handles1)) handles1 (list handles1))
- (if (listp (car handles2)) handles2 (list handles2))))
-
-;; Copy of function from mm-decode.el
-(mh-defun-compat mm-set-handle-multipart-parameter (handle parameter value)
- ;; HANDLE could be a CTL.
- (if handle
- (put-text-property 0 (length (car handle)) parameter value
- (car handle))))
-
-;; Copy of original macro is in mm-decode.el
-(mh-defun-compat mm-handle-multipart-ctl-parameter (handle parameter)
- (get-text-property 0 parameter (car handle)))
-
-(mh-do-in-xemacs (defvar default-enable-multibyte-characters))
-
-;; Copy of original function in mm-decode.el
-(mh-defun-compat mm-readable-p (handle)
- "Say whether the content of HANDLE is readable."
- (and (< (with-current-buffer (mm-handle-buffer handle)
- (buffer-size)) 10000)
- (mm-with-unibyte-buffer
- (mm-insert-part handle)
- (and (eq (mm-body-7-or-8) '7bit)
- (not (mm-long-lines-p 76))))))
-
-;; Copy of original function in mm-bodies.el
-(mh-defun-compat mm-long-lines-p (length)
- "Say whether any of the lines in the buffer is longer than LINES."
- (save-excursion
- (goto-char (point-min))
- (end-of-line)
- (while (and (not (eobp))
- (not (> (current-column) length)))
- (forward-line 1)
- (end-of-line))
- (and (> (current-column) length)
- (current-column))))
-
-(mh-defun-compat mm-keep-viewer-alive-p (handle)
- ;; Released Gnus doesn't keep handles associated with externally displayed
- ;; MIME parts. So this will always return nil.
- nil)
-
-(mh-defun-compat mm-destroy-parts (list)
- "Older emacs don't have this function."
- nil)
-
-;;; This is mm-save-part from gnus 5.10 since that function in emacs21.2 is
-;;; buggy (the args to read-file-name are incorrect). When all supported
-;;; versions of Emacs come with at least Gnus 5.10, we can delete this
-;;; function and rename calls to mh-mm-save-part to mm-save-part.
-(defun mh-mm-save-part (handle)
- "Write HANDLE to a file."
- (let ((name (mail-content-type-get (mm-handle-type handle) 'name))
- (filename (mail-content-type-get
- (mm-handle-disposition handle) 'filename))
- file)
- (when filename
- (setq filename (file-name-nondirectory filename)))
- (setq file (read-file-name "Save MIME part to: "
- (or mm-default-directory
- default-directory)
- nil nil (or filename name "")))
- (setq mm-default-directory (file-name-directory file))
- (and (or (not (file-exists-p file))
- (yes-or-no-p (format "File %s already exists; overwrite? "
- file)))
- (mm-save-part-to-file handle file))))
-
-\f
-
;;; MIME cleanup
;;;###mh-autoload
I have seen this only in spam, so maybe we shouldn't fix this ;-)"
(save-excursion
(goto-char (point-min))
- (when (and (message-fetch-field "content-type")
- (not (message-fetch-field "mime-version")))
- (when (search-forward "\n\n" nil t)
- (forward-line -1)
+ (re-search-forward "\n\n" nil t)
+ (save-restriction
+ (narrow-to-region (point-min) (point))
+ (when (and (message-fetch-field "content-type")
+ (not (message-fetch-field "mime-version")))
+ (goto-char (point-min))
(insert "MIME-Version: 1.0\n")))))
+(defun mh-small-show-buffer-p ()
+ "Check if show buffer is small.
+This is used to decide if smileys and graphical emphasis will be displayed."
+ (let ((max nil))
+ (when (and (boundp 'font-lock-maximum-size) font-lock-maximum-size)
+ (cond ((numberp font-lock-maximum-size)
+ (setq max font-lock-maximum-size))
+ ((listp font-lock-maximum-size)
+ (setq max (cdr (or (assoc 'mh-show-mode font-lock-maximum-size)
+ (assoc t font-lock-maximum-size)))))))
+ (or (not (numberp max)) (>= (/ max 8) (buffer-size)))))
+
;;;###mh-autoload
(defun mh-display-smileys ()
"Function to display smileys."
- (when (and mh-graphical-smileys-flag
- (fboundp 'smiley-region)
- (boundp 'font-lock-maximum-size)
- font-lock-maximum-size
- (>= (/ font-lock-maximum-size 8) (buffer-size)))
- (smiley-region (point-min) (point-max))))
+ (when (and mh-graphical-smileys-flag (mh-small-show-buffer-p))
+ (mh-funcall-if-exists smiley-region (point-min) (point-max))))
;;;###mh-autoload
(defun mh-display-emphasis ()
"Function to display graphical emphasis."
- (when (and mh-graphical-emphasis-flag
- (if font-lock-maximum-size
- (>= (/ font-lock-maximum-size 8) (buffer-size))))
+ (when (and mh-graphical-emphasis-flag (mh-small-show-buffer-p))
(flet ((article-goto-body ())) ; shadow this function to do nothing
(save-excursion
(goto-char (point-min))
(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
(defun mh-decode-message-body ()
"Decode message based on charset.
If message has been encoded for transfer take that into account."
- (let* ((ct (ignore-errors (mail-header-parse-content-type
- (message-fetch-field "Content-Type" t))))
- (charset (mail-content-type-get ct 'charset))
- (cte (message-fetch-field "Content-Transfer-Encoding")))
+ (let (ct charset cte)
+ (goto-char (point-min))
+ (re-search-forward "\n\n" nil t)
+ (save-restriction
+ (narrow-to-region (point-min) (point))
+ (setq ct (ignore-errors (mail-header-parse-content-type
+ (message-fetch-field "Content-Type" t)))
+ charset (mail-content-type-get ct 'charset)
+ cte (message-fetch-field "Content-Transfer-Encoding")))
(when (stringp cte) (setq cte (mail-header-strip cte)))
(when (or (not ct) (equal (car ct) "text/plain"))
(save-restriction
(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))
(defun mh-mime-display-alternative (handles)
"Choose among the alternatives, HANDLES the part that will be displayed.
If no part is preferred then all the parts are displayed."
- (let ((preferred (mm-preferred-alternative handles)))
+ (let* ((preferred (mm-preferred-alternative handles))
+ (others (loop for x in handles unless (eq x preferred) collect x)))
(cond ((and preferred (stringp (car preferred)))
- (mh-mime-display-part preferred))
+ (mh-mime-display-part preferred)
+ (mh-mime-maybe-display-alternatives others))
(preferred
(save-restriction
(narrow-to-region (point) (if (eobp) (point) (1+ (point))))
(mh-mime-display-single preferred)
+ (mh-mime-maybe-display-alternatives others)
(goto-char (point-max))))
(t (mh-mime-display-mixed handles)))))
+(defun mh-mime-maybe-display-alternatives (alternatives)
+ "Show buttons for ALTERNATIVES.
+If `mh-mime-display-alternatives-flag' is non-nil then display buttons for
+alternative parts that are usually suppressed."
+ (when (and mh-display-buttons-for-alternatives-flag alternatives)
+ (insert "\n----------------------------------------------------\n")
+ (insert "Alternatives:\n")
+ (dolist (x alternatives)
+ (insert "\n")
+ (mh-insert-mime-button x (mh-mime-part-index x) nil))
+ (insert "\n----------------------------------------------------\n")))
+
(defun mh-mime-display-mixed (handles)
"Display the list of MIME parts, HANDLES recursively."
(mapcar #'mh-mime-display-part handles))
(setf (gethash handle (mh-mime-part-index-hash (mh-buffer-data)))
(incf (mh-mime-parts-count (mh-buffer-data))))))
-;;; Avoid compiler warnings for XEmacs functions...
-(eval-when (compile)
- (loop for function in '(glyph-width window-pixel-width
- glyph-height window-pixel-height)
- do (or (fboundp function) (defalias function 'ignore))))
-
(defun mh-small-image-p (handle)
"Decide whether HANDLE is a \"small\" image that can be displayed inline.
This is only useful if a Content-Disposition header is not present."
; this only tells us if the image is
; something that emacs can display
(let* ((image (mm-get-image handle)))
- (cond ((fboundp 'glyph-width)
- ;; XEmacs -- totally untested, copied from gnus
- (and (mh-funcall-if-exists glyphp image)
- (< (glyph-width image)
- (or mh-max-inline-image-width
- (window-pixel-width)))
- (< (glyph-height image)
- (or mh-max-inline-image-height
- (window-pixel-height)))))
- ((fboundp 'image-size)
- ;; Emacs21 -- copied from gnus
- (let ((size (mh-funcall-if-exists image-size image)))
- (and size
- (< (cdr size)
- (or mh-max-inline-image-height
- (1- (window-height))))
- (< (car size)
- (or mh-max-inline-image-width (window-width))))))
- (t
- ;; Can't show image inline
- nil))))))
+ (or (mh-do-in-xemacs
+ (and (mh-funcall-if-exists glyphp image)
+ (< (glyph-width image)
+ (or mh-max-inline-image-width (window-pixel-width)))
+ (< (glyph-height image)
+ (or mh-max-inline-image-height
+ (window-pixel-height)))))
+ (mh-do-in-gnu-emacs
+ (let ((size (mh-funcall-if-exists image-size image)))
+ (and size
+ (< (cdr size) (or mh-max-inline-image-height
+ (1- (window-height))))
+ (< (car size) (or mh-max-inline-image-width
+ (window-width)))))))))))
(defun mh-inline-vcard-p (handle)
"Decide if HANDLE is a vcard that must be displayed inline."
(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
(progn
;; Delete the button and displayed part (if any)
(let ((region (get-text-property point 'mh-region)))
- (when (and region (fboundp 'remove-images))
+ (when region
(mh-funcall-if-exists
remove-images (car region) (cdr region)))
(mm-display-part handle)
(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))
displayed. This function is called when the mouse is used to click the MIME
button."
(interactive "e")
- (save-excursion
- (let* ((event-window
- (or (mh-funcall-if-exists posn-window (event-start event));GNU Emacs
- (mh-funcall-if-exists event-window event))) ;XEmacs
- (event-position
- (or (mh-funcall-if-exists posn-point (event-start event)) ;GNU Emacs
- (mh-funcall-if-exists event-closest-point event))) ;XEmacs
- (original-window (selected-window))
- (original-position (progn
- (set-buffer (window-buffer event-window))
- (set-marker (make-marker) (point))))
- (folder mh-show-folder-buffer)
- (mm-inline-media-tests mh-mm-inline-media-tests)
- (data (get-text-property event-position 'mh-data))
- (function (get-text-property event-position 'mh-callback))
- (buffer-read-only nil))
- (unwind-protect
- (progn
- (select-window event-window)
- (flet ((mm-handle-set-external-undisplayer (handle func)
- (mh-handle-set-external-undisplayer folder handle func)))
- (goto-char event-position)
- (and function (funcall function data))))
- (set-buffer-modified-p nil)
- (goto-char original-position)
- (set-marker original-position nil)
- (select-window original-window)))))
+ (mh-do-at-event-location event
+ (let ((folder mh-show-folder-buffer)
+ (mm-inline-media-tests mh-mm-inline-media-tests)
+ (data (get-text-property (point) 'mh-data))
+ (function (get-text-property (point) 'mh-callback)))
+ (flet ((mm-handle-set-external-undisplayer (handle func)
+ (mh-handle-set-external-undisplayer folder handle func)))
+ (and function (funcall function data))))))
;;;###mh-autoload
(defun mh-mime-save-part ()
(interactive)
(let ((data (get-text-property (point) 'mh-data)))
(when data
- (let ((mm-default-directory mh-mime-save-parts-directory))
+ (let ((mm-default-directory
+ (file-name-as-directory (or mh-mime-save-parts-directory
+ default-directory))))
(mh-mm-save-part data)
(setq mh-mime-save-parts-directory mm-default-directory)))))
(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