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