# HG changeset patch # User Richard M. Stallman # Date 1234584008 0 # Node ID a92cde59fabcf9095aa31582dea40b5f552cd0b3 # Parent 34e51f3bcf52270df34faa2e44e0ae6abca79865 Handle editing of header fields. (rmail-old-headers): New variable. (rmail-edit-current-message): Set it, recording current headers. (rmail-cease-edit): Compute new headers and diff against old ones. Update the mbox buffer with the changes that were made. (rmail-edit-headers-alist): New function. (rmail-edit-diff-headers, rmail-edit-update-headers): New functions. diff -r 34e51f3bcf52 -r a92cde59fabc lisp/mail/rmailedit.el --- a/lisp/mail/rmailedit.el Sat Feb 14 03:41:44 2009 +0000 +++ b/lisp/mail/rmailedit.el Sat Feb 14 04:00:08 2009 +0000 @@ -69,25 +69,33 @@ ;; Rmail Edit mode is suitable only for specially formatted data. (put 'rmail-edit-mode 'mode-class 'special) - + (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")) - (set (make-local-variable 'rmail-old-pruned) (rmail-msg-is-pruned)) + (make-local-variable 'rmail-old-pruned) + (setq rmail-old-pruned (rmail-msg-is-pruned)) (rmail-edit-mode) - (set (make-local-variable 'rmail-old-text) - (save-restriction - (widen) - (buffer-substring (point-min) (point-max)))) + (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 @@ -128,6 +136,7 @@ (insert "\n"))) (let ((old rmail-old-text) (pruned rmail-old-pruned) + new-headers character-coding is-text-message coding-system headers-end limit) ;; Go back to Rmail mode, but carefully. @@ -147,6 +156,7 @@ (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)) @@ -174,6 +184,11 @@ 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") @@ -199,6 +214,130 @@ (insert rmail-old-text) (rmail-cease-edit) (rmail-highlight-headers)) + +(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. Show the previous new header. + (unless old + (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)