1 ;;; rmailout.el --- "RMAIL" mail reader for Emacs: output message to a file
3 ;; Copyright (C) 1985, 1987, 1993, 1994, 2001, 2002, 2003, 2004, 2005,
4 ;; 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
9 ;; This file is part of GNU Emacs.
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.
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.
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/>.
31 (defcustom rmail-output-decode-coding nil
32 "If non-nil, do coding system decoding when outputting message as Babyl."
37 (defcustom rmail-output-file-alist nil
38 "Alist matching regexps to suggested output Rmail files.
39 This is a list of elements of the form (REGEXP . NAME-EXP).
40 The suggestion is taken if REGEXP matches anywhere in the message buffer.
41 NAME-EXP may be a string constant giving the file name to use,
42 or more generally it may be any kind of expression that returns
43 a file name as a string."
44 :type
'(repeat (cons regexp
46 (string :tag
"File Name")
50 (defcustom rmail-fields-not-to-output nil
51 "Regexp describing fields to exclude when outputting a message to a file.
52 The function `rmail-delete-unwanted-fields' uses this, ignoring case."
53 :type
'(choice (const :tag
"None" nil
)
57 (defun rmail-output-read-file-name ()
58 "Read the file name to use for `rmail-output'.
59 Set `rmail-default-file' to this name as well as returning it."
62 (setq tail rmail-output-file-alist
)
63 ;; Suggest a file based on a pattern match.
64 (while (and tail
(not answer
))
66 (goto-char (point-min))
67 (if (re-search-forward (car (car tail
)) nil t
)
68 (setq answer
(eval (cdr (car tail
)))))
69 (setq tail
(cdr tail
))))
70 ;; If no suggestion, use same file as last time.
71 (or answer rmail-default-file
))))
75 (concat "Output message to mail file (default "
76 (file-name-nondirectory default-file
)
78 (file-name-directory default-file
)
79 (abbreviate-file-name default-file
))
80 (file-name-directory default-file
))))
81 (setq rmail-default-file
82 (if (file-directory-p read-file
)
83 (expand-file-name (file-name-nondirectory default-file
)
86 (or read-file
(file-name-nondirectory default-file
))
87 (file-name-directory default-file
)))))))
89 (defun rmail-delete-unwanted-fields (preserve)
90 "Delete all headers matching `rmail-fields-not-to-output'.
91 Retains headers matching the regexp PRESERVE. Ignores case.
92 The buffer should be narrowed to just the header."
93 (if rmail-fields-not-to-output
95 (goto-char (point-min))
96 (let ((case-fold-search t
))
97 (while (re-search-forward rmail-fields-not-to-output nil t
)
99 (unless (looking-at preserve
)
100 (delete-region (point) (line-beginning-position 2))))))))
102 (defun rmail-output-as-babyl (file-name nomsg
)
103 "Convert the current buffer's text to Babyl and output to FILE-NAME.
104 Alters the current buffer's text, so it should be a temporary buffer.
105 If a buffer is visiting FILE-NAME, adds the text to that buffer
106 rather than saving the file directly. If the buffer is an Rmail buffer,
107 updates it accordingly. If no buffer is visiting FILE-NAME, appends
108 the text directly to FILE-NAME, and displays a \"Wrote file\" message
109 unless NOMSG is a symbol (neither nil nor t)."
110 (let ((coding-system-for-write 'emacs-mule-unix
))
112 (goto-char (point-min))
113 (search-forward "\n\n" nil
'move
)
114 (narrow-to-region (point-min) (point))
115 (if rmail-fields-not-to-output
116 (rmail-delete-unwanted-fields nil
)))
118 ;; Convert to Babyl format.
119 (rmail-convert-to-babyl-format)
120 ;; Write it into the file, or its buffer.
121 (let ((buf (find-buffer-visiting file-name
))
122 (tembuf (current-buffer)))
124 (write-region (point-min) (point-max) file-name t nomsg
)
125 (if (eq buf
(current-buffer))
126 (error "Can't output message to same file it's already in"))
127 ;; File has been visited, in buffer BUF.
129 (let ((inhibit-read-only t
)
130 (msg (bound-and-true-p rmail-current-message
)))
131 ;; If MSG is non-nil, buffer is in RMAIL mode.
133 (rmail-output-to-babyl-buffer tembuf msg
)
134 ;; Output file not in rmail mode => just insert at the end.
135 (narrow-to-region (point-min) (1+ (buffer-size)))
136 (goto-char (point-max))
137 (insert-buffer-substring tembuf
)))))))
139 ;; Called only if rmail-summary-exists, which means rmailsum is loaded.
140 (declare-function rmail-update-summary
"rmailsum" (&rest ignore
))
142 (defun rmail-output-to-babyl-buffer (tembuf msg
)
143 "Copy message in TEMBUF into the current Babyl Rmail buffer.
144 Do what is necessary to make Rmail know about the new message, then
145 display message number MSG."
146 ;; Turn on Auto Save mode, if it's off in this buffer but enabled by default.
147 (and (not buffer-auto-save-file-name
)
150 (rmail-maybe-set-message-counters)
152 (narrow-to-region (point-max) (point-max))
153 (insert-buffer-substring tembuf
)
154 (goto-char (point-min))
156 (search-backward "\n\^_")
157 (narrow-to-region (point) (point-max))
158 (rmail-count-new-messages t
)
159 (if (rmail-summary-exists)
160 (rmail-select-summary (rmail-update-summary)))
161 (rmail-show-message-1 msg
))
163 (defun rmail-convert-to-babyl-format ()
164 "Convert the mbox message in the current buffer to Babyl format."
165 (let ((count 0) (start (point-min))
166 (case-fold-search nil
)
167 (buffer-undo-list t
))
168 (goto-char (point-min))
170 (unless (looking-at "^From ")
171 (error "Invalid mbox message"))
172 (insert "\^L\n0,,\n*** EOOH ***\n")
173 (rmail-nuke-pinhead-header)
174 ;; Decode base64 or quoted printable contents, Rmail style.
175 (let* ((header-end (save-excursion
176 (and (re-search-forward "\n\n" nil t
)
179 (quoted-printable-header-field-end
182 "^content-transfer-encoding:\\(\n?[\t ]\\)*quoted-printable\\(\n?[\t ]\\)*"
184 (base64-header-field-end
186 ;; Don't decode non-text data.
189 "^content-type:\\(\n?[\t ]\\)\\(text\\|message\\)/"
193 "^content-transfer-encoding:\\(\n?[\t ]\\)*base64\\(\n?[\t ]\\)*"
196 (goto-char (point-max))
197 (if quoted-printable-header-field-end
199 (unless (mail-unquote-printable-region
200 header-end
(point) nil t t
)
201 (message "Malformed MIME quoted-printable message"))
202 ;; Change "quoted-printable" to "8bit",
203 ;; to reflect the decoding we just did.
204 (goto-char quoted-printable-header-field-end
)
205 (delete-region (point) (search-backward ":"))
207 (if base64-header-field-end
209 (when (condition-case nil
211 (base64-decode-region
214 ;; Prevent base64-decode-region
215 ;; from removing newline characters.
216 (skip-chars-backward "\n\t ")
220 ;; Change "base64" to "8bit", to reflect the
221 ;; decoding we just did.
222 (goto-char base64-header-field-end
)
223 (delete-region (point) (search-backward ":"))
224 (insert ": 8bit")))))
225 ;; Transform anything within the message text
226 ;; that might appear to be the end of a Babyl-format message.
229 (narrow-to-region start
(point))
230 (goto-char (point-min))
231 (while (search-forward "\n\^_" nil t
) ; single char
232 (replace-match "\n^_")))) ; 2 chars: "^" and "_"
233 ;; This is for malformed messages that don't end in newline.
234 ;; There shouldn't be any, but some users say occasionally
236 (or (bolp) (newline))
238 (setq last-coding-system-used nil
)
239 ;; Decode coding system, following specs in the message header,
240 ;; and record what coding system was decoded.
241 (if rmail-output-decode-coding
245 (search-forward "\n\n" nil t
)
246 (let ((case-fold-search t
))
248 rmail-mime-charset-pattern
250 (intern (downcase (match-string 1))))))
251 (rmail-decode-region start
(point) mime-charset
)))
255 (insert "X-Coding-System: "
256 (symbol-name last-coding-system-used
)
259 (defun rmail-nuke-pinhead-header ()
260 "Delete the \"From \" line in the current mbox message.
261 The variable `rmail-unix-mail-delimiter' specifies the From line format.
262 Replaces the From line with a \"Mail-from\" header. Adds \"Date\" and
263 \"From\" headers if they are not already present."
266 (let ((start (point))
269 (search-forward "\n\n")
271 (goto-char (point-max))
275 (narrow-to-region start end
)
276 (let ((case-fold-search t
))
278 (setq has-from
(search-forward "\nFrom:" nil t
))
280 (setq has-date
(and (search-forward "\nDate:" nil t
) (point)))
282 (let ((case-fold-search nil
))
283 (if (re-search-forward (concat "^" rmail-unix-mail-delimiter
) nil t
)
287 ;; Keep and reformat the date if we don't
288 ;; have a Date: field.
292 "Date: \\2, \\4 \\3 \\9 \\5 "
294 ;; The timezone could be matched by group 7 or group 10.
295 ;; If neither of them matched, assume EST, since only
296 ;; Easterners would be so sloppy.
297 ;; It's a shame the substitution can't use "\\10".
299 ((/= (match-beginning 7) (match-end 7)) "\\7")
300 ((/= (match-beginning 10) (match-end 10))
301 (buffer-substring (match-beginning 10)
305 ;; Keep and reformat the sender if we don't
306 ;; have a From: field.
312 (autoload 'mail-mbox-from
"mail-utils")
314 (defun rmail-output-as-mbox (file-name nomsg
&optional as-seen
)
315 "Convert the current buffer's text to mbox and output to FILE-NAME.
316 Alters the current buffer's text, so it should be a temporary buffer.
317 If a buffer is visiting FILE-NAME, adds the text to that buffer
318 rather than saving the file directly. If the buffer is an Rmail buffer,
319 updates it accordingly. If no buffer is visiting FILE-NAME, appends
320 the text directly to FILE-NAME, and displays a \"Wrote file\" message
321 unless NOMSG is a symbol (neither nil nor t).
322 AS-SEEN is non-nil if we are copying the message \"as seen\"."
323 (let ((case-fold-search t
)
325 (goto-char (point-min))
326 ;; Preserve the Mail-From and MIME-Version fields
327 ;; even if they have been pruned.
328 (search-forward "\n\n" nil
'move
)
329 (narrow-to-region (point-min) (point))
330 (rmail-delete-unwanted-fields
331 (if rmail-enable-mime
"Mail-From"
332 "Mail-From\\|MIME-Version\\|Content-type"))
333 (goto-char (point-min))
334 (or (looking-at "From ")
335 (insert (mail-mbox-from)))
337 ;; Make sure message ends with blank line.
338 (goto-char (point-max))
339 (rmail-ensure-blank-line)
340 (goto-char (point-min))
341 (let ((buf (find-buffer-visiting file-name
))
342 (tembuf (current-buffer)))
344 (let ((coding-system-for-write 'raw-text-unix
))
345 ;; FIXME should ensure existing file ends with a blank line.
346 (write-region (point-min) (point-max) file-name t nomsg
))
347 (if (eq buf
(current-buffer))
348 (error "Can't output message to same file it's already in"))
349 ;; File has been visited, in buffer BUF.
351 (let ((inhibit-read-only t
)
352 (msg (and (boundp 'rmail-current-message
)
353 rmail-current-message
)))
355 (error "Can't output \"as seen\" to a visited Rmail file"))
357 (rmail-output-to-rmail-buffer tembuf msg
)
358 ;; Output file not in Rmail mode => just insert at the end.
359 (narrow-to-region (point-min) (1+ (buffer-size)))
360 (goto-char (point-max))
361 (insert-buffer-substring tembuf
)))))))
363 (defun rmail-output-to-rmail-buffer (tembuf msg
)
364 "Copy message in TEMBUF into the current Rmail buffer.
365 Do what is necessary to make Rmail know about the new message. then
366 display message number MSG."
368 (rmail-swap-buffers-maybe)
369 (rmail-modify-format)
370 ;; Turn on Auto Save mode, if it's off in this buffer but enabled
372 (and (not buffer-auto-save-file-name
)
375 (rmail-maybe-set-message-counters)
376 ;; Insert the new message after the last old message.
378 ;; Make sure the last old message ends with a blank line.
379 (goto-char (point-max))
380 (rmail-ensure-blank-line)
381 ;; Insert the new message at the end.
382 (narrow-to-region (point-max) (point-max))
383 (insert-buffer-substring tembuf
)
384 (rmail-count-new-messages t
)
385 ;; FIXME should re-use existing windows.
386 (if (rmail-summary-exists)
387 (rmail-select-summary (rmail-update-summary)))
388 (rmail-show-message-1 msg
)))
390 ;;; There are functions elsewhere in Emacs that use this function;
391 ;;; look at them before you change the calling method.
393 (defun rmail-output (file-name &optional count noattribute not-rmail
)
394 "Append this message to mail file FILE-NAME.
395 Writes mbox format, unless FILE-NAME exists and is Babyl format, in which
396 case it writes Babyl.
398 Interactively, the default file name comes from `rmail-default-file',
399 which is updated to the name you use in this command. In all uses, if
400 FILE-NAME is not absolute, it is expanded with the directory part of
401 `rmail-default-file'.
403 If a buffer is visiting FILE-NAME, adds the text to that buffer
404 rather than saving the file directly. If the buffer is an Rmail
405 buffer, updates it accordingly.
407 This command always outputs the complete message header, even if
408 the header display is currently pruned.
410 Optional prefix argument COUNT (default 1) says to output that
411 many consecutive messages, starting with the current one (ignoring
412 deleted messages). If `rmail-delete-after-output' is non-nil, deletes
413 messages after output.
415 The optional third argument NOATTRIBUTE, if non-nil, says not to
416 set the `filed' attribute, and not to display a \"Wrote file\"
417 message (if writing a file directly).
419 Set the optional fourth argument NOT-RMAIL non-nil if you call this
420 from a non-Rmail buffer. In this case, COUNT is ignored."
422 (list (rmail-output-read-file-name)
423 (prefix-numeric-value current-prefix-arg
)))
424 (or count
(setq count
1))
426 (expand-file-name file-name
427 (and rmail-default-file
428 (file-name-directory rmail-default-file
))))
429 ;; Warn about creating new file.
430 (or (find-buffer-visiting file-name
)
431 (file-exists-p file-name
)
432 (yes-or-no-p (concat "\"" file-name
"\" does not exist, create it? "))
433 (error "Output file does not exist"))
434 (if noattribute
(setq noattribute
'nomsg
))
435 (let ((babyl-format (and (file-readable-p file-name
)
436 (mail-file-babyl-p file-name
)))
437 (cur (current-buffer))
438 (buf (find-buffer-visiting file-name
)))
440 ;; If a babyl file is visited in a buffer, is it visited as babyl
442 (and babyl-format buf
443 (with-current-buffer buf
447 (goto-char (point-min))
449 (looking-at "BABYL OPTIONS:"))))))
451 (if not-rmail
; eg via message-fcc-handler-function
453 (insert-buffer-substring cur
)
454 ;; Output in the appropriate format.
457 (goto-char (point-min))
458 ;; rmail-convert-to-babyl-format errors if no From line,
459 ;; whereas rmail-output-as-mbox inserts one.
460 (or (looking-at "From ")
461 (insert (mail-mbox-from)))
462 (rmail-output-as-babyl file-name noattribute
))
463 (rmail-output-as-mbox file-name noattribute
)))
464 ;; Called from an Rmail buffer.
466 (set-buffer rmail-buffer
)
467 (error "There is no Rmail buffer"))
468 (let ((orig-count count
)
471 (setq beg
(rmail-msgbeg rmail-current-message
)
472 end
(rmail-msgend rmail-current-message
))
473 ;; All access to the buffer's local variables is now finished...
475 ;; ... so it is ok to go to a different buffer.
476 (if (rmail-buffers-swapped-p) (set-buffer rmail-view-buffer
))
477 (setq cur
(current-buffer))
481 (insert-buffer-substring cur beg end
)
483 (rmail-output-as-babyl file-name noattribute
)
484 (rmail-output-as-mbox file-name noattribute
)))))
485 (or noattribute
; mark message as "filed"
486 (rmail-set-attribute rmail-filed-attr-index t
))
487 (setq count
(1- count
))
488 (let ((next-message-p
489 (if rmail-delete-after-output
490 (rmail-delete-forward)
492 (rmail-next-undeleted-message 1))))
493 (num-appended (- orig-count count
)))
494 (if (and (> count
0) (not next-message-p
))
495 (error "Only %d message%s appended" num-appended
496 (if (= num-appended
1) "" "s")))))))))
498 ;; FIXME nothing outside uses this, so NOT-RMAIL could be dropped.
499 ;; FIXME this duplicates code from rmail-output.
501 (defun rmail-output-as-seen (file-name &optional count noattribute not-rmail
)
502 "Append this message to mbox file named FILE-NAME.
503 The details are as for `rmail-output', except that:
504 i) the header is output as currently seen
505 ii) this function cannot write to Babyl files
506 iii) an Rmail buffer cannot be visiting FILE-NAME
508 Note that if NOT-RMAIL is non-nil, there is no difference between this
509 function and `rmail-output'. This argument may be removed in future,
510 so you should call `rmail-output' directly in that case."
512 (list (rmail-output-read-file-name)
513 (prefix-numeric-value current-prefix-arg
)))
515 (rmail-output file-name count noattribute not-rmail
)
516 (or count
(setq count
1))
518 (expand-file-name file-name
519 (and rmail-default-file
520 (file-name-directory rmail-default-file
))))
521 ;; Warn about creating new file.
522 (or (find-buffer-visiting file-name
)
523 (file-exists-p file-name
)
524 (yes-or-no-p (concat "\"" file-name
"\" does not exist, create it? "))
525 (error "Output file does not exist"))
527 (if (and (file-readable-p file-name
) (mail-file-babyl-p file-name
))
528 (error "Cannot output `as seen' to a Babyl file"))
529 (if noattribute
(setq noattribute
'nomsg
))
531 (set-buffer rmail-buffer
)
532 (error "There is no Rmail buffer"))
533 (let ((orig-count count
)
534 (cur (current-buffer)))
537 ;; If operating from whole-mbox buffer, get message bounds.
538 (or (rmail-buffers-swapped-p)
539 (setq beg
(rmail-msgbeg rmail-current-message
)
540 end
(rmail-msgend rmail-current-message
)))
543 ;; If operating from the view buffer, get the bounds.
545 (setq beg
(point-min)
548 (insert-buffer-substring cur beg end
)
549 (rmail-output-as-mbox file-name noattribute t
))))
550 (or noattribute
; mark message as "filed"
551 (rmail-set-attribute rmail-filed-attr-index t
))
552 (setq count
(1- count
))
553 (let ((next-message-p
554 (if rmail-delete-after-output
555 (rmail-delete-forward)
557 (rmail-next-undeleted-message 1))))
558 (num-appended (- orig-count count
)))
559 (if (and (> count
0) (not next-message-p
))
560 (error "Only %d message%s appended" num-appended
561 (if (= num-appended
1) "" "s"))))))))
565 (defun rmail-output-body-to-file (file-name)
566 "Write this message body to the file FILE-NAME.
567 Interactively, the default file name comes from either the message
568 \"Subject\" header, or from `rmail-default-body-file'. Updates the value
569 of `rmail-default-body-file' accordingly. In all uses, if FILE-NAME
570 is not absolute, it is expanded with the directory part of
571 `rmail-default-body-file'.
573 Note that this overwrites FILE-NAME (after confirmation), rather
574 than appending to it. Deletes the message after writing if
575 `rmail-delete-after-output' is non-nil."
578 (or (mail-fetch-field "Subject")
579 rmail-default-body-file
)))
581 (replace-regexp-in-string ":" "-" default-file
))
583 (replace-regexp-in-string " " "-" default-file
))
584 (list (setq rmail-default-body-file
586 "Output message body to file: "
587 (and default-file
(file-name-directory default-file
))
589 nil default-file
)))))
591 (expand-file-name file-name
592 (and rmail-default-body-file
593 (file-name-directory rmail-default-body-file
))))
595 (goto-char (point-min))
596 (search-forward "\n\n")
597 (and (file-exists-p file-name
)
598 (not (y-or-n-p (format "File %s exists; overwrite? " file-name
)))
599 (error "Operation aborted"))
600 (write-region (point) (point-max) file-name
))
601 (if rmail-delete-after-output
602 (rmail-delete-forward)))
604 ;; arch-tag: 4059abf0-f249-4be4-8e0d-602d370d01d1
605 ;;; rmailout.el ends here