;;; rmailedit.el --- "RMAIL edit mode" Edit the current message
-;; Copyright (C) 1985, 1994, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007 Free Software Foundation, Inc.
+;; Copyright (C) 1985, 1994, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
+;; 2008, 2009 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: mail
;; This file is part of GNU Emacs.
-;; GNU Emacs is free software; you can redistribute it and/or modify
+;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-;; Boston, MA 02110-1301, USA.
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
:version "21.1"
:group 'rmail-edit)
-(defvar rmail-old-text)
-(defvar rmail-edit-map nil)
-(if rmail-edit-map
- nil
- ;; Make a keymap that inherits text-mode-map.
- (setq rmail-edit-map (make-sparse-keymap))
- (set-keymap-parent rmail-edit-map text-mode-map)
- (define-key rmail-edit-map "\C-c\C-c" 'rmail-cease-edit)
- (define-key rmail-edit-map "\C-c\C-]" 'rmail-abort-edit))
+(defvar rmail-edit-map
+ (let ((map (make-sparse-keymap)))
+ ;; Make a keymap that inherits text-mode-map.
+ (set-keymap-parent map text-mode-map)
+ (define-key map "\C-c\C-c" 'rmail-cease-edit)
+ (define-key map "\C-c\C-]" 'rmail-abort-edit)
+ map))
-;; Rmail Edit mode is suitable only for specially formatted data.
-(put 'rmail-edit-mode 'mode-class 'special)
+(declare-function rmail-summary-disable "rmailsum" ())
(defun rmail-edit-mode ()
"Major mode for editing the contents of an RMAIL message.
* \\[rmail-cease-edit] makes them permanent.
This functions runs the normal hook `rmail-edit-mode-hook'.
\\{rmail-edit-map}"
- (delay-mode-hooks (text-mode))
- (use-local-map rmail-edit-map)
- (setq major-mode 'rmail-edit-mode)
- (setq mode-name "RMAIL Edit")
- (if (boundp 'mode-line-modified)
- (setq mode-line-modified (default-value 'mode-line-modified))
- (setq mode-line-format (default-value 'mode-line-format)))
(if (rmail-summary-exists)
- (save-excursion
- (set-buffer rmail-summary-buffer)
+ (with-current-buffer rmail-summary-buffer
(rmail-summary-disable)))
- (run-mode-hooks 'rmail-edit-mode-hook))
+ (let ((rmail-buffer-swapped nil)) ; Prevent change-major-mode-hook
+ ; from unswapping the buffers.
+ (delay-mode-hooks (text-mode))
+ (use-local-map rmail-edit-map)
+ (setq major-mode 'rmail-edit-mode)
+ (setq mode-name "RMAIL Edit")
+ (if (boundp 'mode-line-modified)
+ (setq mode-line-modified (default-value 'mode-line-modified))
+ (setq mode-line-format (default-value 'mode-line-format)))
+ (run-mode-hooks 'rmail-edit-mode-hook)))
+
+;; Rmail Edit mode is suitable only for specially formatted data.
+(put 'rmail-edit-mode 'mode-class 'special)
+\f
-(defvar rmail-old-pruned nil)
+(defvar rmail-old-text)
+(defvar rmail-old-pruned nil
+ "Non-nil means the message being edited originally had pruned headers.")
(put 'rmail-old-pruned 'permanent-local t)
-(defvar rmail-edit-saved-coding-system nil)
-(put 'rmail-edit-saved-coding-system 'permanent-local t)
+(defvar rmail-old-headers nil
+ "Holds the headers of this message before editing started.")
+(put 'rmail-old-headers 'permanent-local t)
;;;###autoload
(defun rmail-edit-current-message ()
"Edit the contents of this message."
(interactive)
+ (if (zerop rmail-total-messages)
+ (error "No messages in this buffer"))
(make-local-variable 'rmail-old-pruned)
(setq rmail-old-pruned (rmail-msg-is-pruned))
- (make-local-variable 'rmail-edit-saved-coding-system)
- (setq rmail-edit-saved-coding-system save-buffer-coding-system)
- (rmail-toggle-header 0)
(rmail-edit-mode)
- ;; As the local value of save-buffer-coding-system is deleted by
- ;; rmail-edit-mode, we restore the original value.
- (make-local-variable 'save-buffer-coding-system)
- (setq save-buffer-coding-system rmail-edit-saved-coding-system)
(make-local-variable 'rmail-old-text)
- (setq rmail-old-text (buffer-substring (point-min) (point-max)))
+ (setq rmail-old-text
+ (save-restriction
+ (widen)
+ (buffer-substring (point-min) (point-max))))
+ (make-local-variable 'rmail-old-headers)
+ (setq rmail-old-headers (rmail-edit-headers-alist t))
(setq buffer-read-only nil)
+ (setq buffer-undo-list nil)
+ ;; FIXME whether the buffer is initially marked as modified or not
+ ;; depends on whether or not the underlying rmail buffer was so marked.
+ ;; Seems poor.
(force-mode-line-update)
(if (and (eq (key-binding "\C-c\C-c") 'rmail-cease-edit)
(eq (key-binding "\C-c\C-]") 'rmail-abort-edit))
(message "%s" (substitute-command-keys
"Editing: Type \\[rmail-cease-edit] to return to Rmail, \\[rmail-abort-edit] to abort"))))
+
+(declare-function rmail-summary-enable "rmailsum" ())
+
(defun rmail-cease-edit ()
"Finish editing message; switch back to Rmail proper."
(interactive)
(if (rmail-summary-exists)
- (save-excursion
- (set-buffer rmail-summary-buffer)
+ (with-current-buffer rmail-summary-buffer
(rmail-summary-enable)))
- ;; Make sure buffer ends with a newline.
+ (widen)
+ ;; Disguise any "From " lines so they don't start a new message.
+ (save-excursion
+ (goto-char (point-min))
+ (or rmail-old-pruned (forward-line 1))
+ (while (re-search-forward "^>*From " nil t)
+ (beginning-of-line)
+ (insert ">")
+ (forward-line)))
+ ;; Make sure buffer ends with a blank line
+ ;; so as not to run this message together with the following one.
(save-excursion
(goto-char (point-max))
(if (/= (preceding-char) ?\n)
(insert "\n"))
- ;; Adjust the marker that points to the end of this message.
- (set-marker (aref rmail-message-vector (1+ rmail-current-message))
- (point)))
- (let ((old rmail-old-text))
+ (unless (looking-back "\n\n")
+ (insert "\n")))
+ (let ((old rmail-old-text)
+ (pruned rmail-old-pruned)
+ ;; People who know what they are doing might have modified the
+ ;; buffer's encoding if editing the message included inserting
+ ;; characters that were unencodable by the original message's
+ ;; encoding. Make note of the new encoding and use it for
+ ;; encoding the edited message.
+ (edited-coding buffer-file-coding-system)
+ new-headers
+ character-coding is-text-message coding-system
+ headers-end limit)
+ ;; Make sure `edited-coding' can safely encode the edited message.
+ (setq edited-coding
+ (select-safe-coding-system (point-min) (point-max) edited-coding))
+ ;; Go back to Rmail mode, but carefully.
(force-mode-line-update)
- (kill-all-local-variables)
- (rmail-mode-1)
- (rmail-variables)
- ;; As the local value of save-buffer-coding-system is changed by
- ;; rmail-variables, we restore the original value.
- (setq save-buffer-coding-system rmail-edit-saved-coding-system)
- (if (and (= (length old) (- (point-max) (point-min)))
- (string= old (buffer-substring (point-min) (point-max))))
- ()
+ (let ((rmail-buffer-swapped nil)) ; Prevent change-major-mode-hook
+ ; from unswapping the buffers.
+ (kill-all-local-variables)
+ (rmail-mode-1)
+ (if (boundp 'tool-bar-map)
+ (set (make-local-variable 'tool-bar-map) rmail-tool-bar-map))
+ (setq buffer-undo-list t)
+ (rmail-variables))
+ ;; If text has really changed, mark message as edited.
+ (unless (and (= (length old) (- (point-max) (point-min)))
+ (string= old (buffer-substring (point-min) (point-max))))
(setq old nil)
- (rmail-set-attribute "edited" t)
- (if (boundp 'rmail-summary-vector)
- (progn
- (aset rmail-summary-vector (1- rmail-current-message) nil)
- (save-excursion
- (rmail-widen-to-current-msgbeg
- (function (lambda ()
- (forward-line 2)
- (if (looking-at "Summary-line: ")
- (let ((buffer-read-only nil))
- (delete-region (point)
- (progn (forward-line 1)
- (point))))))))))))
+ (goto-char (point-min))
+ ;; If they changed the message's encoding, rewrite the charset=
+ ;; header for them, so that subsequent rmail-show-message
+ ;; decodes it correctly.
+ (let ((buffer-read-only nil)
+ (new-coding (coding-system-base edited-coding))
+ old-coding mime-charset mime-beg mime-end)
+ (when (re-search-forward rmail-mime-charset-pattern
+ (1- (save-excursion (search-forward "\n\n")))
+ 'move)
+ (setq mime-beg (match-beginning 1)
+ mime-end (match-end 1)
+ old-coding (coding-system-from-name (match-string 1))))
+ (setq mime-charset
+ (symbol-name
+ (or (coding-system-get new-coding :mime-charset)
+ (if (coding-system-equal new-coding 'undecided)
+ 'us-ascii
+ new-coding))))
+ (cond
+ ((null old-coding)
+ ;; If there was no charset= spec, insert one.
+ (insert "Content-type: text/plain; charset=" mime-charset "\n"))
+ ((not (coding-system-equal (coding-system-base old-coding)
+ new-coding))
+ (delete-region mime-beg mime-end)
+ (insert mime-charset))))
+ (goto-char (point-min))
+ (search-forward "\n\n")
+ (setq headers-end (point))
+ (setq new-headers (rmail-edit-headers-alist t))
+ (rmail-swap-buffers-maybe)
+ (narrow-to-region (rmail-msgbeg rmail-current-message)
+ (rmail-msgend rmail-current-message))
+ (save-restriction
+ (setq limit
+ (save-excursion
+ (goto-char (point-min))
+ (search-forward "\n\n" nil t)))
+ ;; All 3 of the functions we call below assume the buffer was
+ ;; narrowed to just the headers of the message.
+ (narrow-to-region (rmail-msgbeg rmail-current-message) limit)
+ (setq character-coding
+ (mail-fetch-field "content-transfer-encoding")
+ is-text-message (rmail-is-text-p)
+ coding-system (if (and edited-coding
+ (not (coding-system-equal
+ (coding-system-base edited-coding)
+ 'undecided)))
+ edited-coding
+ (rmail-get-coding-system))))
+ (if character-coding
+ (setq character-coding (downcase character-coding)))
+
+ (goto-char limit)
+ (let ((inhibit-read-only t))
+ (let ((data-buffer (current-buffer))
+ (end (copy-marker (point) t)))
+ (with-current-buffer rmail-view-buffer
+ (encode-coding-region headers-end (point-max) coding-system
+ data-buffer))
+ (delete-region end (point-max)))
+
+ ;; Apply to the mbox buffer any changes in header fields
+ ;; that the user made while editing in the view buffer.
+ (rmail-edit-update-headers (rmail-edit-diff-headers
+ rmail-old-headers new-headers))
+
+ ;; Re-apply content-transfer-encoding, if any, on the message body.
+ (cond
+ ((string= character-coding "quoted-printable")
+ (mail-quote-printable-region (point) (point-max)))
+ ((and (string= character-coding "base64") is-text-message)
+ (base64-encode-region (point) (point-max)))
+ ((and (eq character-coding 'uuencode) is-text-message)
+ (error "uuencoded messages are not supported"))))
+ (rmail-set-attribute rmail-edited-attr-index t))
+ ;;??? BROKEN perhaps.
+;;; (if (boundp 'rmail-summary-vector)
+;;; (aset rmail-summary-vector (1- rmail-current-message) nil))
(save-excursion
(rmail-show-message)
- (rmail-toggle-header (if rmail-old-pruned 1 0))))
- (run-hooks 'rmail-mode-hook)
- (setq buffer-read-only t))
+ (rmail-toggle-header (if pruned 1 0))))
+ (run-hooks 'rmail-mode-hook))
(defun rmail-abort-edit ()
"Abort edit of current message; restore original contents."
(interactive)
+ (widen)
(delete-region (point-min) (point-max))
(insert rmail-old-text)
(rmail-cease-edit)
(rmail-highlight-headers))
+\f
+(defun rmail-edit-headers-alist (&optional widen markers)
+ "Return an alist of the headers of the message in the current buffer.
+Each element has the form (HEADER-NAME . ENTIRE-STRING).
+ENTIRE-STRING includes the name of the header field (which is HEADER-NAME)
+and has a final newline.
+If part of the text is not valid as a header field, HEADER-NAME
+is an integer and we use consecutive integers.
+
+If WIDEN is non-nil, operate on the entire buffer.
+
+If MARKERS is non-nil, the value looks like
+ \(HEADER-NAME ENTIRE-STRING BEG-MARKER END-MARKER)."
+ (let (header-alist (no-good-header-count 1))
+ (save-excursion
+ (save-restriction
+ (if widen (widen))
+ (goto-char (point-min))
+ (search-forward "\n\n")
+ (narrow-to-region (point-min) (1- (point)))
+ (goto-char (point-min))
+ (while (not (eobp))
+ (let ((start (point))
+ name header)
+ ;; Match the name.
+ (if (looking-at "[ \t]*\\([^:\n \t]\\(\\|[^:\n]*[^:\n \t]\\)\\)[ \t]*:")
+ (setq name (match-string-no-properties 1))
+ (setq name no-good-header-count
+ no-good-header-count (1+ no-good-header-count)))
+ (forward-line 1)
+ (while (looking-at "[ \t]")
+ (forward-line 1))
+ (setq header (buffer-substring-no-properties start (point)))
+ (if markers
+ (push (list header (copy-marker start) (point-marker))
+ header-alist)
+ (push (cons name header) header-alist))))))
+ (nreverse header-alist)))
+
+
+(defun rmail-edit-diff-headers (old-headers new-headers)
+ "Compare OLD-HEADERS and NEW-HEADERS and return field differences.
+The value is a list of three lists, (INSERTED DELETED CHANGED).
+
+INSERTED's elements describe inserted header fields
+and each looks like (AFTER-WHAT INSERT-WHAT)
+INSERT-WHAT is the header field to insert (a member of NEW-HEADERS).
+AFTER-WHAT is the field to insert it after (a member of NEW-HEADERS)
+or else nil to insert it at the beginning.
+
+DELETED's elements are elements of OLD-HEADERS.
+CHANGED's elements have the form (OLD . NEW)
+where OLD is a element of OLD-HEADERS and NEW is an element of NEW-HEADERS."
+
+ (let ((reverse-new (reverse new-headers))
+ inserted deleted changed)
+ (dolist (old old-headers)
+ (let ((new (assoc (car old) new-headers)))
+ ;; If it's in OLD-HEADERS and has no new counterpart,
+ ;; it is a deletion.
+ (if (null new)
+ (push old deleted)
+ ;; If it has a new counterpart, maybe it was changed.
+ (unless (equal (cdr old) (cdr new))
+ (push (cons old new) changed))
+ ;; Remove the new counterpart, since it has been spoken for.
+ (setq new-headers (remq new new-headers)))))
+ ;; Look at the new headers with no old counterpart.
+ (dolist (new new-headers)
+ (let ((prev (cadr (member new reverse-new))))
+ ;; Mark each one as an insertion.
+ ;; Record the previous new header, to insert it after that.
+ (push (list prev new) inserted)))
+ ;; It is crucial to return the insertions in buffer order
+ ;; so that `rmail-edit-update-headers' can insert a field
+ ;; after a new field.
+ (list (nreverse inserted)
+ (nreverse deleted)
+ (nreverse changed))))
+
+(defun rmail-edit-update-headers (header-diff)
+ "Edit the mail headers in the buffer based on HEADER-DIFF.
+HEADER-DIFF should be a return value from `rmail-edit-diff-headers'."
+ (let ((buf-headers (rmail-edit-headers-alist nil t)))
+ ;; Change all the fields scheduled for being changed.
+ (dolist (chg (nth 2 header-diff))
+ (let* ((match (assoc (cdar chg) buf-headers))
+ (end (marker-position (nth 2 match))))
+ (goto-char end)
+ ;; Insert the new, then delete the old.
+ ;; That avoids collapsing markers.
+ (insert-before-markers (cddr chg))
+ (delete-region (nth 1 match) end)
+ ;; Remove the old field from BUF-HEADERS.
+ (setq buf-headers (delq match buf-headers))
+ ;; Update BUF-HEADERS to show the changed field.
+ (push (list (cddr chg) (point-marker)
+ (copy-marker (- (point) (length (cddr chg))))
+ (point-marker))
+ buf-headers)))
+ ;; Delete all the fields scheduled for deletion.
+ ;; We do deletion after changes
+ ;; because when two fields look alike and get replaced by one,
+ ;; the first of them is considered changed
+ ;; and the second is considered deleted.
+ (dolist (del (nth 1 header-diff))
+ (let ((match (assoc (cdr del) buf-headers)))
+ (delete-region (nth 1 match) (nth 2 match))))
+ ;; Insert all the fields scheduled for insertion.
+ (dolist (ins (nth 0 header-diff))
+ (let* ((new (cadr ins))
+ (after (car ins))
+ (match (assoc (cdr after) buf-headers)))
+ (goto-char (if match (nth 2 match) (point-min)))
+ (insert (cdr new))
+ ;; Update BUF-HEADERS to show the inserted field.
+ (push (list (cdr new)
+ (copy-marker (- (point) (length (cdr new))))
+ (point-marker))
+ buf-headers)))
+ ;; Disconnect the markers
+ (dolist (hdr buf-headers)
+ (set-marker (nth 1 hdr) nil)
+ (set-marker (nth 2 hdr) nil))))
(provide 'rmailedit)
-;;; arch-tag: 93c22709-a14a-46c1-ab91-52c3f5a0ec12
+;; arch-tag: 9524f335-12cc-4e95-9e9b-3208dc30550b
;;; rmailedit.el ends here
HCoop / bpt / emacs.git / blobdiff