[bpt/emacs.git] / lisp / mail / rmailedit.el

;;; rmailedit.el --- "RMAIL edit mode"  Edit the current message

;; 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
;; it under the terms of the GNU General Public License as published by
;; 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
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;;; Code:

(require 'rmail)

(defcustom rmail-edit-mode-hook nil
  "List of functions to call when editing an RMAIL message."
  :type 'hook
  :version "21.1"
  :group 'rmail-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))

(declare-function rmail-summary-disable "rmailsum" ())

(defun rmail-edit-mode ()
  "Major mode for editing the contents of an Rmail message.
The editing commands are the same as in Text mode, together with
two commands to return to regular Rmail:
  *  \\[rmail-abort-edit] cancels any changes and returns to Rmail
  *  \\[rmail-cease-edit] makes them permanent.
This function runs the hooks `text-mode-hook' and `rmail-edit-mode-hook'.
\\{rmail-edit-map}"
  (if (rmail-summary-exists)
      (with-current-buffer rmail-summary-buffer
	(rmail-summary-disable)))
  ;; Prevent change-major-mode-hook from unswapping the buffers.
  (let ((rmail-buffer-swapped nil))
    (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 someone uses C-x C-s, don't clobber the rmail file (bug#2625).
    (add-hook 'write-region-annotate-functions
	      'rmail-write-region-annotate nil t)
    (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-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-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))
  (rmail-edit-mode)
  (make-local-variable 'rmail-old-text)
  (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 "Editing: Type C-c C-c to return to Rmail, C-c C-] to abort")
    (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)
      (with-current-buffer rmail-summary-buffer
	(rmail-summary-enable)))
  (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))
    (rmail-ensure-blank-line))
  (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)
    (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)
      (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 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: 9524f335-12cc-4e95-9e9b-3208dc30550b
;;; rmailedit.el ends here
Commit	Line	Data
537ab246 BG	1	;;; rmailedit.el --- "RMAIL edit mode" Edit the current message
537ab246 BG	2
a8e8f947 GM	3	;; Copyright (C) 1985, 1994, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
a8e8f947 GM	4	;; 2008, 2009 Free Software Foundation, Inc.
537ab246 BG	5
	6	;; Maintainer: FSF
	7	;; Keywords: mail
	8
	9	;; This file is part of GNU Emacs.
	10
	11	;; GNU Emacs is free software: you can redistribute it and/or modify
	12	;; it under the terms of the GNU General Public License as published by
	13	;; the Free Software Foundation, either version 3 of the License, or
	14	;; (at your option) any later version.
	15
	16	;; GNU Emacs is distributed in the hope that it will be useful,
	17	;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	18	;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	19	;; GNU General Public License for more details.
	20
	21	;; You should have received a copy of the GNU General Public License
	22	;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
	23
	24	;;; Commentary:
	25
	26	;;; Code:
	27
a8e8f947	28	(require 'rmail)
537ab246 BG	29
	30	(defcustom rmail-edit-mode-hook nil
	31	"List of functions to call when editing an RMAIL message."
	32	:type 'hook
	33	:version "21.1"
	34	:group 'rmail-edit)
	35
537ab246	36
befa8175 SM	37	(defvar rmail-edit-map
	38	(let ((map (make-sparse-keymap)))
	39	;; Make a keymap that inherits text-mode-map.
	40	(set-keymap-parent map text-mode-map)
	41	(define-key map "\C-c\C-c" 'rmail-cease-edit)
	42	(define-key map "\C-c\C-]" 'rmail-abort-edit)
	43	map))
	44
04c17bea	45	(declare-function rmail-summary-disable "rmailsum" ())
537ab246 BG	46
537ab246 BG	47	(defun rmail-edit-mode ()
24683c51 GM	48	"Major mode for editing the contents of an Rmail message.
	49	The editing commands are the same as in Text mode, together with
	50	two commands to return to regular Rmail:
	51	* \\[rmail-abort-edit] cancels any changes and returns to Rmail
537ab246	52	* \\[rmail-cease-edit] makes them permanent.
24683c51	53	This function runs the hooks `text-mode-hook' and `rmail-edit-mode-hook'.
537ab246 BG	54	\\{rmail-edit-map}"
537ab246 BG	55	(if (rmail-summary-exists)
befa8175	56	(with-current-buffer rmail-summary-buffer
537ab246	57	(rmail-summary-disable)))
24683c51 GM	58	;; Prevent change-major-mode-hook from unswapping the buffers.
24683c51 GM	59	(let ((rmail-buffer-swapped nil))
537ab246 BG	60	(delay-mode-hooks (text-mode))
	61	(use-local-map rmail-edit-map)
	62	(setq major-mode 'rmail-edit-mode)
	63	(setq mode-name "RMAIL Edit")
	64	(if (boundp 'mode-line-modified)
	65	(setq mode-line-modified (default-value 'mode-line-modified))
	66	(setq mode-line-format (default-value 'mode-line-format)))
52b9c461 GM	67	;; If someone uses C-x C-s, don't clobber the rmail file (bug#2625).
	68	(add-hook 'write-region-annotate-functions
	69	'rmail-write-region-annotate nil t)
537ab246 BG	70	(run-mode-hooks 'rmail-edit-mode-hook)))
537ab246 BG	71
a8e8f947 GM	72	;; Rmail Edit mode is suitable only for specially formatted data.
a8e8f947 GM	73	(put 'rmail-edit-mode 'mode-class 'special)
24683c51	74	\f
a8e8f947 GM	75
	76	(defvar rmail-old-text)
	77	(defvar rmail-old-pruned nil
	78	"Non-nil means the message being edited originally had pruned headers.")
537ab246 BG	79	(put 'rmail-old-pruned 'permanent-local t)
537ab246 BG	80
1945c7a7 RS	81	(defvar rmail-old-headers nil
	82	"Holds the headers of this message before editing started.")
	83	(put 'rmail-old-headers 'permanent-local t)
	84
537ab246 BG	85	;;;###autoload
	86	(defun rmail-edit-current-message ()
	87	"Edit the contents of this message."
	88	(interactive)
a8e8f947	89	(if (zerop rmail-total-messages)
537ab246	90	(error "No messages in this buffer"))
1945c7a7 RS	91	(make-local-variable 'rmail-old-pruned)
1945c7a7 RS	92	(setq rmail-old-pruned (rmail-msg-is-pruned))
537ab246	93	(rmail-edit-mode)
1945c7a7 RS	94	(make-local-variable 'rmail-old-text)
	95	(setq rmail-old-text
	96	(save-restriction
	97	(widen)
	98	(buffer-substring (point-min) (point-max))))
	99	(make-local-variable 'rmail-old-headers)
	100	(setq rmail-old-headers (rmail-edit-headers-alist t))
537ab246 BG	101	(setq buffer-read-only nil)
537ab246 BG	102	(setq buffer-undo-list nil)
a8e8f947 GM	103	;; FIXME whether the buffer is initially marked as modified or not
	104	;; depends on whether or not the underlying rmail buffer was so marked.
	105	;; Seems poor.
537ab246 BG	106	(force-mode-line-update)
	107	(if (and (eq (key-binding "\C-c\C-c") 'rmail-cease-edit)
	108	(eq (key-binding "\C-c\C-]") 'rmail-abort-edit))
	109	(message "Editing: Type C-c C-c to return to Rmail, C-c C-] to abort")
	110	(message "%s" (substitute-command-keys
	111	"Editing: Type \\[rmail-cease-edit] to return to Rmail, \\[rmail-abort-edit] to abort"))))
	112
a8e8f947 GM	113
	114	(declare-function rmail-summary-enable "rmailsum" ())
	115
537ab246 BG	116	(defun rmail-cease-edit ()
	117	"Finish editing message; switch back to Rmail proper."
	118	(interactive)
	119	(if (rmail-summary-exists)
befa8175	120	(with-current-buffer rmail-summary-buffer
537ab246 BG	121	(rmail-summary-enable)))
	122	(widen)
	123	;; Disguise any "From " lines so they don't start a new message.
	124	(save-excursion
	125	(goto-char (point-min))
a8e8f947	126	(or rmail-old-pruned (forward-line 1))
b3a51d1d	127	(while (re-search-forward "^>*From " nil t)
537ab246	128	(beginning-of-line)
b3a51d1d CY	129	(insert ">")
b3a51d1d CY	130	(forward-line)))
da5f6330 GM	131	;; Make sure buffer ends with a blank line so as not to run this
da5f6330 GM	132	;; message together with the following one.
537ab246 BG	133	(save-excursion
537ab246 BG	134	(goto-char (point-max))
da5f6330	135	(rmail-ensure-blank-line))
537ab246	136	(let ((old rmail-old-text)
a8e8f947	137	(pruned rmail-old-pruned)
ff4abce9 EZ	138	;; People who know what they are doing might have modified the
	139	;; buffer's encoding if editing the message included inserting
	140	;; characters that were unencodable by the original message's
	141	;; encoding. Make note of the new encoding and use it for
	142	;; encoding the edited message.
	143	(edited-coding buffer-file-coding-system)
1945c7a7	144	new-headers
537ab246	145	character-coding is-text-message coding-system
782c80e8	146	headers-end limit)
ff4abce9 EZ	147	;; Make sure `edited-coding' can safely encode the edited message.
	148	(setq edited-coding
	149	(select-safe-coding-system (point-min) (point-max) edited-coding))
537ab246 BG	150	;; Go back to Rmail mode, but carefully.
537ab246 BG	151	(force-mode-line-update)
befa8175 SM	152	(let ((rmail-buffer-swapped nil)) ; Prevent change-major-mode-hook
befa8175 SM	153	; from unswapping the buffers.
537ab246 BG	154	(kill-all-local-variables)
	155	(rmail-mode-1)
	156	(if (boundp 'tool-bar-map)
	157	(set (make-local-variable 'tool-bar-map) rmail-tool-bar-map))
	158	(setq buffer-undo-list t)
	159	(rmail-variables))
	160	;; If text has really changed, mark message as edited.
	161	(unless (and (= (length old) (- (point-max) (point-min)))
	162	(string= old (buffer-substring (point-min) (point-max))))
	163	(setq old nil)
	164	(goto-char (point-min))
ff4abce9 EZ	165	;; If they changed the message's encoding, rewrite the charset=
	166	;; header for them, so that subsequent rmail-show-message
	167	;; decodes it correctly.
	168	(let ((buffer-read-only nil)
	169	(new-coding (coding-system-base edited-coding))
	170	old-coding mime-charset mime-beg mime-end)
	171	(when (re-search-forward rmail-mime-charset-pattern
	172	(1- (save-excursion (search-forward "\n\n")))
	173	'move)
	174	(setq mime-beg (match-beginning 1)
	175	mime-end (match-end 1)
	176	old-coding (coding-system-from-name (match-string 1))))
	177	(setq mime-charset
	178	(symbol-name
	179	(or (coding-system-get new-coding :mime-charset)
	180	(if (coding-system-equal new-coding 'undecided)
	181	'us-ascii
	182	new-coding))))
	183	(cond
	184	((null old-coding)
	185	;; If there was no charset= spec, insert one.
	186	(insert "Content-type: text/plain; charset=" mime-charset "\n"))
	187	((not (coding-system-equal (coding-system-base old-coding)
	188	new-coding))
	189	(delete-region mime-beg mime-end)
	190	(insert mime-charset))))
	191	(goto-char (point-min))
537ab246 BG	192	(search-forward "\n\n")
537ab246 BG	193	(setq headers-end (point))
1945c7a7	194	(setq new-headers (rmail-edit-headers-alist t))
537ab246	195	(rmail-swap-buffers-maybe)
aaaaa276	196	(narrow-to-region (rmail-msgbeg rmail-current-message)
782c80e8	197	(rmail-msgend rmail-current-message))
782c80e8 EZ	198	(save-restriction
	199	(setq limit
	200	(save-excursion
	201	(goto-char (point-min))
	202	(search-forward "\n\n" nil t)))
	203	;; All 3 of the functions we call below assume the buffer was
	204	;; narrowed to just the headers of the message.
	205	(narrow-to-region (rmail-msgbeg rmail-current-message) limit)
	206	(setq character-coding
	207	(mail-fetch-field "content-transfer-encoding")
	208	is-text-message (rmail-is-text-p)
ff4abce9 EZ	209	coding-system (if (and edited-coding
	210	(not (coding-system-equal
	211	(coding-system-base edited-coding)
	212	'undecided)))
	213	edited-coding
	214	(rmail-get-coding-system))))
537ab246 BG	215	(if character-coding
	216	(setq character-coding (downcase character-coding)))
	217
782c80e8	218	(goto-char limit)
aaaaa276 EZ	219	(let ((inhibit-read-only t))
	220	(let ((data-buffer (current-buffer))
	221	(end (copy-marker (point) t)))
	222	(with-current-buffer rmail-view-buffer
	223	(encode-coding-region headers-end (point-max) coding-system
	224	data-buffer))
	225	(delete-region end (point-max)))
537ab246	226
1945c7a7 RS	227	;; Apply to the mbox buffer any changes in header fields
	228	;; that the user made while editing in the view buffer.
	229	(rmail-edit-update-headers (rmail-edit-diff-headers
	230	rmail-old-headers new-headers))
	231
a8e8f947	232	;; Re-apply content-transfer-encoding, if any, on the message body.
537ab246 BG	233	(cond
537ab246 BG	234	((string= character-coding "quoted-printable")
aaaaa276	235	(mail-quote-printable-region (point) (point-max)))
537ab246	236	((and (string= character-coding "base64") is-text-message)
aaaaa276	237	(base64-encode-region (point) (point-max)))
782c80e8	238	((and (eq character-coding 'uuencode) is-text-message)
a8e8f947 GM	239	(error "uuencoded messages are not supported"))))
a8e8f947 GM	240	(rmail-set-attribute rmail-edited-attr-index t))
537ab246	241	;;??? BROKEN perhaps.
a8e8f947 GM	242	;;; (if (boundp 'rmail-summary-vector)
	243	;;; (aset rmail-summary-vector (1- rmail-current-message) nil))
	244	(save-excursion
	245	(rmail-show-message)
	246	(rmail-toggle-header (if pruned 1 0))))
537ab246 BG	247	(run-hooks 'rmail-mode-hook))
	248
	249	(defun rmail-abort-edit ()
	250	"Abort edit of current message; restore original contents."
	251	(interactive)
	252	(widen)
	253	(delete-region (point-min) (point-max))
	254	(insert rmail-old-text)
	255	(rmail-cease-edit)
	256	(rmail-highlight-headers))
1945c7a7 RS	257	\f
	258	(defun rmail-edit-headers-alist (&optional widen markers)
	259	"Return an alist of the headers of the message in the current buffer.
	260	Each element has the form (HEADER-NAME . ENTIRE-STRING).
	261	ENTIRE-STRING includes the name of the header field (which is HEADER-NAME)
	262	and has a final newline.
	263	If part of the text is not valid as a header field, HEADER-NAME
	264	is an integer and we use consecutive integers.
	265
	266	If WIDEN is non-nil, operate on the entire buffer.
	267
	268	If MARKERS is non-nil, the value looks like
	269	\(HEADER-NAME ENTIRE-STRING BEG-MARKER END-MARKER)."
	270	(let (header-alist (no-good-header-count 1))
	271	(save-excursion
	272	(save-restriction
	273	(if widen (widen))
	274	(goto-char (point-min))
	275	(search-forward "\n\n")
	276	(narrow-to-region (point-min) (1- (point)))
	277	(goto-char (point-min))
	278	(while (not (eobp))
	279	(let ((start (point))
	280	name header)
	281	;; Match the name.
	282	(if (looking-at "[ \t]\\([^:\n \t]\\(\\\|[^:\n][^:\n \t]\\)\\)[ \t]*:")
	283	(setq name (match-string-no-properties 1))
	284	(setq name no-good-header-count
	285	no-good-header-count (1+ no-good-header-count)))
	286	(forward-line 1)
	287	(while (looking-at "[ \t]")
	288	(forward-line 1))
	289	(setq header (buffer-substring-no-properties start (point)))
	290	(if markers
	291	(push (list header (copy-marker start) (point-marker))
	292	header-alist)
	293	(push (cons name header) header-alist))))))
	294	(nreverse header-alist)))
	295
	296
	297	(defun rmail-edit-diff-headers (old-headers new-headers)
	298	"Compare OLD-HEADERS and NEW-HEADERS and return field differences.
	299	The value is a list of three lists, (INSERTED DELETED CHANGED).
	300
	301	INSERTED's elements describe inserted header fields
	302	and each looks like (AFTER-WHAT INSERT-WHAT)
	303	INSERT-WHAT is the header field to insert (a member of NEW-HEADERS).
	304	AFTER-WHAT is the field to insert it after (a member of NEW-HEADERS)
	305	or else nil to insert it at the beginning.
	306
	307	DELETED's elements are elements of OLD-HEADERS.
	308	CHANGED's elements have the form (OLD . NEW)
	309	where OLD is a element of OLD-HEADERS and NEW is an element of NEW-HEADERS."
	310
	311	(let ((reverse-new (reverse new-headers))
	312	inserted deleted changed)
	313	(dolist (old old-headers)
	314	(let ((new (assoc (car old) new-headers)))
	315	;; If it's in OLD-HEADERS and has no new counterpart,
	316	;; it is a deletion.
	317	(if (null new)
	318	(push old deleted)
	319	;; If it has a new counterpart, maybe it was changed.
	320	(unless (equal (cdr old) (cdr new))
321	(push (cons old new) changed))
322	;; Remove the new counterpart, since it has been spoken for.
323	(setq new-headers (remq new new-headers)))))
324	;; Look at the new headers with no old counterpart.
325	(dolist (new new-headers)
326	(let ((prev (cadr (member new reverse-new))))
59a6d249 RS	327	;; Mark each one as an insertion.
	328	;; Record the previous new header, to insert it after that.
	329	(push (list prev new) inserted)))
1945c7a7 RS	330	;; It is crucial to return the insertions in buffer order
	331	;; so that `rmail-edit-update-headers' can insert a field
	332	;; after a new field.
	333	(list (nreverse inserted)
	334	(nreverse deleted)
	335	(nreverse changed))))
	336
	337	(defun rmail-edit-update-headers (header-diff)
	338	"Edit the mail headers in the buffer based on HEADER-DIFF.
	339	HEADER-DIFF should be a return value from `rmail-edit-diff-headers'."
	340	(let ((buf-headers (rmail-edit-headers-alist nil t)))
	341	;; Change all the fields scheduled for being changed.
	342	(dolist (chg (nth 2 header-diff))
	343	(let* ((match (assoc (cdar chg) buf-headers))
	344	(end (marker-position (nth 2 match))))
	345	(goto-char end)
	346	;; Insert the new, then delete the old.
	347	;; That avoids collapsing markers.
	348	(insert-before-markers (cddr chg))
	349	(delete-region (nth 1 match) end)
	350	;; Remove the old field from BUF-HEADERS.
	351	(setq buf-headers (delq match buf-headers))
	352	;; Update BUF-HEADERS to show the changed field.
	353	(push (list (cddr chg) (point-marker)
	354	(copy-marker (- (point) (length (cddr chg))))
	355	(point-marker))
	356	buf-headers)))
	357	;; Delete all the fields scheduled for deletion.
	358	;; We do deletion after changes
	359	;; because when two fields look alike and get replaced by one,
	360	;; the first of them is considered changed
	361	;; and the second is considered deleted.
	362	(dolist (del (nth 1 header-diff))
	363	(let ((match (assoc (cdr del) buf-headers)))
	364	(delete-region (nth 1 match) (nth 2 match))))
	365	;; Insert all the fields scheduled for insertion.
	366	(dolist (ins (nth 0 header-diff))
	367	(let* ((new (cadr ins))
	368	(after (car ins))
	369	(match (assoc (cdr after) buf-headers)))
	370	(goto-char (if match (nth 2 match) (point-min)))
	371	(insert (cdr new))
	372	;; Update BUF-HEADERS to show the inserted field.
	373	(push (list (cdr new)
	374	(copy-marker (- (point) (length (cdr new))))
	375	(point-marker))
	376	buf-headers)))
	377	;; Disconnect the markers
	378	(dolist (hdr buf-headers)
	379	(set-marker (nth 1 hdr) nil)
	380	(set-marker (nth 2 hdr) nil))))
537ab246 BG	381
	382	(provide 'rmailedit)
	383
537ab246 BG	384	;; arch-tag: 9524f335-12cc-4e95-9e9b-3208dc30550b
537ab246 BG	385	;;; rmailedit.el ends here