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