" (line-end-position) t)
(progn
(forward-char -2)
(speedbar-do-function-pointer)))))
(defun rmail-speedbar-move-message (_text token _indent)
"From button TEXT, copy current message to the rmail file specified by TOKEN.
TEXT and INDENT are not used."
(dframe-with-attached-buffer
(message "Moving message to %s" token)
;; expand-file-name is needed due to the unhelpful way in which
;; rmail-output expands non-absolute filenames against rmail-default-file.
;; What is the point of that, anyway?
(rmail-output (expand-file-name token))))
;; Functions for setting, getting and encoding the POP password.
;; The password is encoded to prevent it from being easily accessible
;; to "prying eyes." Obviously, this encoding isn't "real security,"
;; nor is it meant to be.
;;;###autoload
(defun rmail-set-remote-password (password)
"Set PASSWORD to be used for retrieving mail from a POP or IMAP server."
(interactive "sPassword: ")
(if password
(setq rmail-encoded-remote-password
(rmail-encode-string password (emacs-pid)))
(setq rmail-remote-password nil)
(setq rmail-encoded-remote-password nil)))
(defun rmail-get-remote-password (imap user host)
"Get the password for retrieving mail from a POP or IMAP server.
If none has been set, the password is found via auth-source. If
you use ~/.authinfo as your auth-source backend, then put
something like the following in that file:
machine mymachine login myloginname password mypassword
If auth-source search yields no result, prompt the user for the
password."
(when (not rmail-encoded-remote-password)
(if (not rmail-remote-password)
(setq rmail-remote-password
(let ((found (nth 0 (auth-source-search
:max 1 :user user :host host
:require '(:secret)))))
(if found
(auth-info-password found)
(read-passwd (if imap
"IMAP password: "
"POP password: "))))))
(rmail-set-remote-password rmail-remote-password)
(setq rmail-remote-password nil))
(rmail-encode-string rmail-encoded-remote-password (emacs-pid)))
(defun rmail-have-password ()
(or rmail-remote-password rmail-encoded-remote-password))
(defun rmail-encode-string (string mask)
"Encode STRING with integer MASK, by taking the exclusive OR of the
lowest byte in the mask with the first character of string, the
second-lowest-byte with the second character of the string, etc.,
restarting at the lowest byte of the mask whenever it runs out.
Returns the encoded string. Calling the function again with an
encoded string (and the same mask) will decode the string."
(setq mask (abs mask)) ; doesn't work if negative
(let* ((string-vector (string-to-vector string)) (i 0)
(len (length string-vector)) (curmask mask) charmask)
(while (< i len)
(if (= curmask 0)
(setq curmask mask))
(setq charmask (% curmask 256))
(setq curmask (ash curmask -8))
(aset string-vector i (logxor charmask (aref string-vector i)))
(setq i (1+ i)))
(concat string-vector)))
(defun rmail-epa-decrypt-1 (mime)
"Decrypt a single GnuPG encrypted text in a message.
The starting string of the encrypted text should have just been regexp-matched.
Argument MIME is non-nil if this is a mime message."
(let* ((armor-start (match-beginning 0))
(armor-prefix (buffer-substring
(line-beginning-position)
armor-start))
(armor-end-regexp)
armor-end after-end
unquote)
(if (string-match "\\'" armor-prefix)
(setq armor-prefix ""))
(setq armor-end-regexp
(concat "^"
armor-prefix
"-----END PGP MESSAGE-----$"))
(setq armor-end (re-search-forward armor-end-regexp
nil t))
(unless armor-end
(error "Encryption armor beginning has no matching end"))
(setq armor-start (move-marker (make-marker) armor-start))
(setq armor-end (move-marker (make-marker) armor-end))
(goto-char armor-start)
;; Because epa--find-coding-system-for-mime-charset not autoloaded.
(require 'epa)
;; Advance over this armor.
(goto-char armor-end)
(setq after-end (- (point-max) armor-end))
(when mime
(save-excursion
(goto-char armor-start)
(re-search-backward "^--" nil t)
(save-restriction
(narrow-to-region (point) armor-start)
;; Use the charset specified in the armor.
(unless coding-system-for-read
(if (re-search-forward "^[ \t]*Charset[ \t\n]*:[ \t\n]*\\(.*\\)" nil t)
(setq coding-system-for-read
(epa--find-coding-system-for-mime-charset
(intern (downcase (match-string 1)))))))
(goto-char (point-min))
(if (re-search-forward "^[ \t]*Content-transfer-encoding[ \t\n]*:[ \t\n]*quoted-printable[ \t]*$" nil t)
(setq unquote t)))))
(when unquote
(let ((inhibit-read-only t))
(mail-unquote-printable-region armor-start
(- (point-max) after-end))))
(condition-case nil
(epa-decrypt-region
armor-start (- (point-max) after-end)
;; Call back this function to prepare the output.
(lambda ()
(let ((inhibit-read-only t))
(delete-region armor-start (- (point-max) after-end))
(goto-char armor-start)
(current-buffer))))
(error nil))
;; Decode any base64-encoded material in what we just decrypted.
(rmail-epa-decode armor-start after-end)
(list armor-start (- (point-max) after-end) mime
armor-end-regexp
(buffer-substring armor-start (- (point-max) after-end)))))
;; Should this have a key-binding, or be in a menu?
;; There doesn't really seem to be an appropriate menu.
;; Eg the edit command is not in a menu either.
(defvar rmail-mime-render-html-function) ; defcustom in rmailmm
(defun rmail-epa-decrypt ()
"Decrypt GnuPG or OpenPGP armors in current message."
(interactive)
;; Save the current buffer here for cleanliness, in case we
;; change it in one of the calls to `epa-decrypt-region'.
(save-excursion
(let (decrypts
(mime (and (eq major-mode 'rmail-mode) (rmail-mime-message-p)))
mime-disabled)
(goto-char (point-min))
;; Turn off mime processing.
(when (and mime
(not (get-text-property (point-min) 'rmail-mime-hidden)))
(setq mime-disabled t)
(rmail-mime))
;; Now find all armored messages in the buffer
;; and decrypt them one by one.
(goto-char (point-min))
(while (re-search-forward "-----BEGIN PGP MESSAGE-----$" nil t)
(let ((coding-system-for-read coding-system-for-read)
(case-fold-search t)
(armor-start (match-beginning 0)))
;; Don't decrypt an armor that was copied into
;; the message from a message it is a reply to.
(or (equal (buffer-substring (line-beginning-position)
armor-start)
"> ")
(push (rmail-epa-decrypt-1 mime) decrypts))))
(when (and decrypts (rmail-buffers-swapped-p))
(when (y-or-n-p "Replace the original message? ")
(when (eq major-mode 'rmail-mode)
(rmail-add-label "decrypt"))
(setq decrypts (nreverse decrypts))
(let ((beg (rmail-msgbeg rmail-current-message))
(end (rmail-msgend rmail-current-message)))
(with-current-buffer rmail-view-buffer
(narrow-to-region beg end)
(goto-char (point-min))
(dolist (d decrypts)
;; Find, in the real Rmail buffer, the same armors
;; that we found and decrypted in the view buffer.
(if (re-search-forward "-----BEGIN PGP MESSAGE-----$" nil t)
(let (armor-start armor-end armor-end-regexp)
(setq armor-start (match-beginning 0)
armor-end-regexp (nth 3 d)
armor-end (re-search-forward
armor-end-regexp
nil t))
;; Found as expected -- now replace it with the decrypt.
(when armor-end
(delete-region armor-start armor-end)
(insert (nth 4 d)))
;; Change the mime type (if this is in a mime part)
;; so this part will display by default
;; when the message is shown later.
(when (nth 2 d)
(goto-char armor-start)
(when (re-search-backward "^--" nil t)
(save-restriction
(narrow-to-region (point) armor-start)
(when (re-search-forward "^content-type[ \t\n]*:[ \t\n]*" nil t)
(when (looking-at "[^\n \t;]+")
(let ((value (match-string 0)))
(unless (member value '("text/plain" "text/html"))
(replace-match "text/plain"))))))))
)))))))
(when (and (null decrypts)
mime mime-disabled)
;; Re-enable mime processing.
(rmail-mime)
;; Find each Show button and show that part.
(while (search-forward " Show " nil t)
(forward-char -2)
(let ((rmail-mime-render-html-function nil)
(entity (get-text-property (point) 'rmail-mime-entity)))
(unless (and (not (stringp entity))
(rmail-mime-entity-truncated entity))
(push-button))))
(goto-char (point-min))
(while (re-search-forward "-----BEGIN PGP MESSAGE-----$" nil t)
(let ((coding-system-for-read coding-system-for-read)
(case-fold-search t))
(push (rmail-epa-decrypt-1 mime) decrypts)))
)
(unless decrypts
(error "Nothing to decrypt")))))
;; Decode all base64-encoded mime sections from BEG to (Z - BACK-FROM-END),
;; so that we save the decoding permanently in the Rmail buffer
;; if we permanently save the decryption.
(defun rmail-epa-decode (beg back-from-end)
(save-excursion
(goto-char beg)
(while (re-search-forward "--------------[0-9a-zA-Z]+\n"
(- (point-max) back-from-end) t)
;; The ending delimiter is a start delimiter if another section follows.
;; Otherwise it is an end delimiter, with -- affixed.
(let ((delim (concat (substring (match-string 0) 0 -1) "\\(\\|--\\)\n")))
(when (looking-at "\
Content-Type: text/[a-z]+; charset=UTF-8; format=flowed
Content-Transfer-Encoding: base64\n")
(goto-char (match-end 0))
;; Sometimes the attachment's headers are followed by blank lines
(while (eolp)
(forward-line 1))
(let ((start (point))
(inhibit-read-only t))
(re-search-forward delim)
(forward-line -1)
;; Sometimes the attachment's contents are followed by blank lines
(while (save-excursion (forward-line -1) (eolp))
(forward-line -1))
(base64-decode-region start (point))
(forward-line 1)))))))
;;;; Desktop support
(defun rmail-restore-desktop-buffer (file-name
_buffer-name
_buffer-misc)
"Restore an rmail buffer specified in a desktop file."
(condition-case nil
(progn
(rmail-input file-name)
(if (eq major-mode 'rmail-mode)
(current-buffer)
rmail-buffer))
(file-locked
(kill-buffer (current-buffer))
nil)))
(add-to-list 'desktop-buffer-mode-handlers
'(rmail-mode . rmail-restore-desktop-buffer))
;; We use this to record the encoding of the current message before
;; saving the message collection.
(defvar rmail-message-encoding nil)
;; Used in `write-region-annotate-functions' to write rmail files.
(defun rmail-write-region-annotate (start _end)
(when (and (null start) rmail-buffer-swapped)
(unless (buffer-live-p rmail-view-buffer)
(error "Buffer `%s' with real text of `%s' has disappeared"
(buffer-name rmail-view-buffer)
(buffer-name (current-buffer))))
(setq rmail-message-encoding buffer-file-coding-system)
(set-buffer rmail-view-buffer)
(widen)
nil))
;; Used to restore the encoding of the buffer where we show the
;; current message, after we save the message collection. This is
;; needed because rmail-write-region-annotate switches buffers behind
;; save-file's back, with the side effect that last-coding-system-used
;; is assigned to buffer-file-coding-system of the wrong buffer.
(defun rmail-after-save-hook ()
(if (or (eq rmail-view-buffer (current-buffer))
(eq rmail-buffer (current-buffer)))
(with-current-buffer
(if (rmail-buffers-swapped-p) rmail-buffer rmail-view-buffer)
(setq buffer-file-coding-system rmail-message-encoding))))
(add-hook 'after-save-hook 'rmail-after-save-hook)
;;; Mailing list support
(defun rmail--mailing-list-message (which)
"Send a message to mailing list whose purpose is identified by WHICH.
WHICH is a symbol, one of `help', `unsubscribe', or `post'."
(let ((header
(cond ((eq which 'help) "List-Help")
((eq which 'unsubscribe) "List-Unsubscribe")
((eq which 'post) "List-Post")))
(msg
(cond ((eq which 'post)
"Write Subject and body, then type \\[%s] to send the message.")
(t
"Type \\[%s] to send the message.")))
address header-list to subject)
(setq address (rmail-get-header header))
(cond ((and address (string-match "<\\(mailto:[^>]*\\)>" address))
(setq address (match-string 1 address))
(setq header-list (rfc6068-parse-mailto-url address)
to (cdr (assoc-string "To" header-list t))
subject (or (cdr (assoc-string "Subject" header-list t)) ""))
(rmail-start-mail nil to subject nil nil rmail-buffer)
(message (substitute-command-keys
(format msg (get mail-user-agent 'sendfunc)))))
(t
(user-error "This message does not specify \"%s\" address"
header)))))
(defun rmail-mailing-list-help ()
"Send Help request to the mailing list which delivered the current message.
This command starts composing an email message to the mailing list
requesting help about the list. When the message is ready, send it
as usual, via your MUA's send-email command."
(interactive nil rmail-mode)
(rmail--mailing-list-message 'help))
(defun rmail-mailing-list-post ()
"Post a message to the mailing list which delivered the current message.
This command starts composing an email message to the mailing list.
Fill the Subject and the body of the message. When the message is
ready, send it as usual, via your MUA's send-email command."
(interactive nil rmail-mode)
(rmail--mailing-list-message 'post))
(defun rmail-mailing-list-unsubscribe ()
"Send unsubscribe request to the mailing list which delivered current message.
This command starts composing an email message to the mailing list
requesting to unsubscribe you from the list. When the message is
ready, send it as usual, via your MUA's send-email command."
(interactive nil rmail-mode)
(rmail--mailing-list-message 'unsubscribe))
(defun rmail-mailing-list-archive ()
"Browse the archive of the mailing list which delivered the current message."
(interactive nil rmail-mode)
(let* ((header (rmail-get-header "List-Archive"))
(url (and (stringp header)
(string-match " *<\\([^>]*\\)>" header)
(match-string 1 header))))
(if url
(browse-url url)
(user-error
"This message does not specify a valid \"List-Archive\" URL"))))
(provide 'rmail)
;;; rmail.el ends here