+;; Shush compiler.
+(defvar mm-verify-function-alist) ; < Emacs 22
+(defvar mm-decrypt-function-alist) ; < Emacs 22
+(defvar pressed-details) ; XEmacs
+
+(defun mh-insert-mime-security-button (handle)
+ "Display buttons for PGP message, HANDLE."
+ (let* ((protocol (mh-mm-handle-multipart-ctl-parameter handle 'protocol))
+ (crypto-type (or (nth 2 (assoc protocol mm-verify-function-alist))
+ (nth 2 (assoc protocol mm-decrypt-function-alist))
+ "Unknown"))
+ (type (concat crypto-type
+ (if (equal (car handle) "multipart/signed")
+ " Signed" " Encrypted")
+ " Part"))
+ (info (or (mh-mm-handle-multipart-ctl-parameter handle 'gnus-info)
+ "Undecided"))
+ (details (mh-mm-handle-multipart-ctl-parameter handle 'gnus-details))
+ pressed-details begin end face)
+ (setq details (if details (concat "\n" details) ""))
+ (setq pressed-details (if mh-mime-security-button-pressed details ""))
+ (setq face (mh-mime-security-button-face info))
+ (unless (bolp) (insert "\n"))
+ (setq begin (point))
+ (gnus-eval-format
+ mh-mime-security-button-line-format
+ mh-mime-security-button-line-format-alist
+ `(,@(mh-gnus-local-map-property mh-mime-security-button-map)
+ mh-button-pressed ,mh-mime-security-button-pressed
+ mh-callback mh-mime-security-press-button
+ mh-line-format ,mh-mime-security-button-line-format
+ mh-data ,handle))
+ (setq end (point))
+ (widget-convert-button 'link begin end
+ :mime-handle handle
+ :action 'mh-widget-press-button
+ :button-keymap mh-mime-security-button-map
+ :button-face face
+ :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"))
+ (warning (if (equal type "decryption")
+ "(passphrase may be incorrect)" "")))
+ (message "%s %s failed %s" crypto-type type warning)))))
+
+(defun mh-mime-security-button-face (info)
+ "Return the button face to use for encrypted/signed mail based on INFO."
+ (cond ((string-match "OK" info) ;Decrypted mail
+ 'mh-show-pgg-good)
+ ((string-match "Failed" info) ;Decryption failed or signature invalid
+ 'mh-show-pgg-bad)
+ ((string-match "Undecided" info);Unprocessed mail
+ 'mh-show-pgg-unknown)
+ ((string-match "Untrusted" info);Key not trusted
+ 'mh-show-pgg-unknown)
+ (t
+ 'mh-show-pgg-good)))
+
+\f
+
+;;; Button Handlers
+
+(defun mh-folder-mime-action (part-index action include-security-flag)
+ "Go to PART-INDEX and carry out ACTION.
+
+If PART-INDEX is nil then go to the next part in the buffer. The
+search for the next buffer wraps around if end of buffer is reached.
+If argument INCLUDE-SECURITY-FLAG is non-nil then include security
+info buttons when searching for a suitable parts."
+ (unless mh-showing-mode
+ (mh-show))
+ (mh-in-show-buffer (mh-show-buffer)
+ (let ((criterion
+ (cond (part-index
+ (lambda (p)
+ (let ((part (get-text-property p 'mh-part)))
+ (and (integerp part) (= part part-index)))))
+ (t (lambda (p)
+ (if include-security-flag
+ (get-text-property p 'mh-data)
+ (integerp (get-text-property p 'mh-part)))))))
+ (point (point)))
+ (cond ((and (get-text-property point 'mh-part)
+ (or (null part-index)
+ (= (get-text-property point 'mh-part) part-index)))
+ (funcall action))
+ ((and (get-text-property point 'mh-data)
+ include-security-flag
+ (null part-index))
+ (funcall action))
+ (t
+ (mh-goto-next-button nil criterion)
+ (if (= (point) point)
+ (message "No matching MIME part found")
+ (funcall action)))))))
+
+;;;###mh-autoload
+(defun mh-goto-next-button (backward-flag &optional criterion)
+ "Search for next button satisfying criterion.
+
+If BACKWARD-FLAG is non-nil search backward in the buffer for a mime
+button.
+If CRITERION is a function or a symbol which has a function binding
+then that function must return non-nil at the button we stop."
+ (unless (or (and (symbolp criterion) (fboundp criterion))
+ (functionp criterion))
+ (setq criterion (lambda (x) t)))
+ ;; Move to the next button in the buffer satisfying criterion
+ (goto-char (or (save-excursion
+ (beginning-of-line)
+ ;; Find point before current button
+ (let ((point-before-current-button
+ (save-excursion
+ (while (get-text-property (point) 'mh-data)
+ (unless (= (forward-line
+ (if backward-flag 1 -1))
+ 0)
+ (if backward-flag
+ (goto-char (point-min))
+ (goto-char (point-max)))))
+ (point))))
+ ;; Skip over current button
+ (while (and (get-text-property (point) 'mh-data)
+ (not (if backward-flag (bobp) (eobp))))
+ (forward-line (if backward-flag -1 1)))
+ ;; Stop at next MIME button if any exists.
+ (block loop
+ (while (/= (progn
+ (unless (= (forward-line
+ (if backward-flag -1 1))
+ 0)
+ (if backward-flag
+ (goto-char (point-max))
+ (goto-char (point-min)))
+ (beginning-of-line))
+ (point))
+ point-before-current-button)
+ (when (and (get-text-property (point) 'mh-data)
+ (funcall criterion (point)))
+ (return-from loop (point))))
+ nil)))
+ (point))))
+
+(defun mh-widget-press-button (widget el)
+ "Callback for widget, WIDGET.
+Parameter EL is unused."
+ (goto-char (widget-get widget :from))
+ (mh-press-button))
+
+(defun mh-press-button ()
+ "View contents of button.
+
+This command is a toggle so if you use it again on the same
+attachment, the attachment is hidden."
+ (interactive)
+ (let ((mm-inline-media-tests mh-mm-inline-media-tests)
+ (data (get-text-property (point) 'mh-data))
+ (function (get-text-property (point) 'mh-callback))
+ (buffer-read-only nil)
+ (folder mh-show-folder-buffer))
+ (flet ((mm-handle-set-external-undisplayer
+ (handle function)
+ (mh-handle-set-external-undisplayer folder handle function)))
+ (when (and function (eolp))
+ (backward-char))
+ (unwind-protect (and function (funcall function data))
+ (set-buffer-modified-p nil)))))
+
+(defun mh-push-button (event)
+ "Click MIME button for EVENT.
+
+If the MIME part is visible then it is removed. Otherwise the
+part is displayed. This function is called when the mouse is used
+to click the MIME button."
+ (interactive "e")
+ (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))))))
+
+(defun mh-handle-set-external-undisplayer (folder handle function)
+ "Replacement for `mm-handle-set-external-undisplayer'.
+
+This is only called in recent versions of Gnus. The MIME handles
+are stored in data structures corresponding to MH-E folder buffer
+FOLDER instead of in Gnus (as in the original). The MIME part,
+HANDLE is associated with the undisplayer FUNCTION."
+ (if (mh-mm-keep-viewer-alive-p handle)
+ (let ((new-handle (copy-sequence handle)))
+ (mm-handle-set-undisplayer new-handle function)
+ (mm-handle-set-undisplayer handle nil)
+ (save-excursion
+ (set-buffer folder)
+ (push new-handle (mh-mime-handles (mh-buffer-data)))))
+ (mm-handle-set-undisplayer handle function)))
+
+(defun mh-mime-security-press-button (handle)
+ "Callback from security button for part HANDLE."
+ (if (mh-mm-handle-multipart-ctl-parameter handle 'gnus-info)
+ (mh-mime-security-show-details handle)
+ (let ((region (mh-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 (mh-mm-handle-multipart-ctl-parameter handle 'buffer)
+ (let* ((mm-verify-option 'known)
+ (mm-decrypt-option 'known)
+ (new (mh-mm-possibly-verify-or-decrypt (cdr handle) handle)))
+ (unless (eq new (cdr handle))
+ (mh-mm-destroy-parts (cdr handle))
+ (setcdr handle new))))
+ (mh-mime-display-security handle)
+ (goto-char point))))
+
+;; 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
+;; to be no way of getting rid of the inserted text.
+(defun mh-mime-security-show-details (handle)
+ "Toggle display of detailed security info for HANDLE."
+ (let ((details (mh-mm-handle-multipart-ctl-parameter handle 'gnus-details)))
+ (when details
+ (let ((mh-mime-security-button-pressed
+ (not (get-text-property (point) 'mh-button-pressed)))
+ (mh-mime-security-button-line-format
+ (get-text-property (point) 'mh-line-format)))
+ (forward-char -1)
+ (while (eq (get-text-property (point) 'mh-line-format)
+ mh-mime-security-button-line-format)
+ (forward-char -1))
+ (forward-char)
+ (save-restriction
+ (narrow-to-region (point) (point))
+ (mh-insert-mime-security-button handle))
+ (delete-region
+ (point)
+ (or (text-property-not-all
+ (point) (point-max)
+ 'mh-line-format mh-mime-security-button-line-format)
+ (point-max)))
+ (forward-line -1)))))
+
+\f
+
+;;; Miscellaneous Article Washing
+
+;;;###mh-autoload
+(defun mh-add-missing-mime-version-header ()
+ "Some mail programs don't put a MIME-Version header.
+I have seen this only in spam, so maybe we shouldn't fix
+this ;-)"
+ (save-excursion
+ (goto-char (point-min))
+ (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")))))
+
+;;;###mh-autoload
+(defun mh-display-smileys ()
+ "Display smileys."
+ (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 ()
+ "Display graphical emphasis."
+ (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))
+ (article-emphasize)))))
+
+(defun mh-small-show-buffer-p ()
+ "Check if show buffer is small.
+This is used to decide if smileys and graphical emphasis should 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)))))
+
+\f
+
+;;; MH-Letter Commands
+
+;; MH-E commands are alphabetical; specific support routines follow command.
+
+;;;###mh-autoload
+(defun mh-compose-forward (&optional description folder range)
+ "Add tag to forward a message.
+
+You are prompted for a content DESCRIPTION, the name of the
+FOLDER in which the messages to forward are located, and a RANGE
+of messages, which defaults to the current message in that
+folder. Check the documentation of `mh-interactive-range' to see
+how RANGE is read in interactive use.
+
+The option `mh-compose-insertion' controls what type of tags are inserted."
+ (interactive
+ (let* ((description
+ (mml-minibuffer-read-description))
+ (folder
+ (mh-prompt-for-folder "Message from"
+ mh-sent-from-folder nil))
+ (default
+ (if (and (equal folder mh-sent-from-folder)
+ (numberp mh-sent-from-msg))
+ mh-sent-from-msg
+ (nth 0 (mh-translate-range folder "cur"))))
+ (range
+ (mh-read-range "Forward" folder
+ (or (and default
+ (number-to-string default))
+ t)
+ t t)))
+ (list description folder range)))
+ (let ((messages (mapconcat 'identity (mh-list-to-string range) " ")))
+ (dolist (message (mh-translate-range folder messages))
+ (if (equal mh-compose-insertion 'mml)
+ (mh-mml-forward-message description folder (format "%s" message))
+ (mh-mh-forward-message description folder (format "%s" message))))))
+
+;;;###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 (and (equal message "") (numberp mh-sent-from-msg))
+ mh-sent-from-msg
+ (string-to-number message))))
+ (cond ((integerp msg)
+ (if (string= "" description)
+ ;; Rationale: mml-attach-file constructs a malformed composition
+ ;; if the description string is empty. This fixes SF #625168.
+ (mml-attach-file (format "%s%s/%d"
+ mh-user-path (substring folder 1) msg)
+ "message/rfc822")
+ (mml-attach-file (format "%s%s/%d"
+ mh-user-path (substring folder 1) msg)
+ "message/rfc822"
+ description)))
+ (t (error "The message number, %s, is not a integer" msg)))))
+
+(defun mh-mh-forward-message (&optional description folder messages)
+ "Add tag to forward a message.
+You are prompted for a content DESCRIPTION, the name of the
+FOLDER in which the messages to forward are located, and the
+MESSAGES' numbers.
+
+See also \\[mh-mh-to-mime]."
+ (interactive (list
+ (mml-minibuffer-read-description)
+ (mh-prompt-for-folder "Message from" mh-sent-from-folder nil)
+ (read-string (concat "Messages"
+ (if (numberp mh-sent-from-msg)
+ (format " (default %d): "
+ mh-sent-from-msg)
+ ": ")))))