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/>.
32 (defcustom rmail-output-decode-coding nil
33 "*If non-nil, do coding system decoding when outputting message as Babyl."
34 :type
'(choice (const :tag
"on" t
)
35 (const :tag
"off" nil
))
39 (defcustom rmail-output-file-alist nil
40 "*Alist matching regexps to suggested output Rmail files.
41 This is a list of elements of the form (REGEXP . NAME-EXP).
42 The suggestion is taken if REGEXP matches anywhere in the message buffer.
43 NAME-EXP may be a string constant giving the file name to use,
44 or more generally it may be any kind of expression that returns
45 a file name as a string."
46 :type
'(repeat (cons regexp
48 (string :tag
"File Name")
52 (defun rmail-output-read-file-name ()
53 "Read the file name to use for `rmail-output'.
54 Set `rmail-default-file' to this name as well as returning it."
57 (setq tail rmail-output-file-alist
)
58 ;; Suggest a file based on a pattern match.
59 (while (and tail
(not answer
))
61 (goto-char (point-min))
62 (if (re-search-forward (car (car tail
)) nil t
)
63 (setq answer
(eval (cdr (car tail
)))))
64 (setq tail
(cdr tail
))))
65 ;; If no suggestion, use same file as last time.
66 (or answer rmail-default-file
))))
70 (concat "Output message to mail file (default "
71 (file-name-nondirectory default-file
)
73 (file-name-directory default-file
)
74 (abbreviate-file-name default-file
))
75 (file-name-directory default-file
))))
76 (setq rmail-default-file
77 (if (file-directory-p read-file
)
78 (expand-file-name (file-name-nondirectory default-file
)
81 (or read-file
(file-name-nondirectory default-file
))
82 (file-name-directory default-file
)))))))
85 (defcustom rmail-fields-not-to-output nil
86 "*Regexp describing fields to exclude when outputting a message to a file."
87 :type
'(choice (const :tag
"None" nil
)
91 ;; Delete from the buffer header fields we don't want output.
92 ;; Buffer should be pre-narrowed to the header.
93 ;; PRESERVE is a regexp for fields NEVER to delete.
94 (defun rmail-delete-unwanted-fields (preserve)
95 (if rmail-fields-not-to-output
97 (goto-char (point-min))
98 (while (re-search-forward rmail-fields-not-to-output nil t
)
100 (unless (looking-at preserve
)
101 (delete-region (point)
102 (progn (forward-line 1) (point))))))))
104 (defun rmail-output-as-babyl (file-name nomsg
)
105 "Convert the current buffer's text to Babyl and output to FILE-NAME.
106 It alters the current buffer's text, so it should be a temp buffer."
107 (let ((coding-system-for-write
110 (goto-char (point-min))
111 (search-forward "\n\n" nil
'move
)
112 (narrow-to-region (point-min) (point))
113 (if rmail-fields-not-to-output
114 (rmail-delete-unwanted-fields nil
)))
116 ;; Convert to Babyl format.
117 (rmail-convert-to-babyl-format)
118 ;; Write it into the file, or its buffer.
119 (let ((buf (find-buffer-visiting file-name
))
120 (tembuf (current-buffer)))
122 (write-region (point-min) (point-max) file-name t nomsg
)
123 (if (eq buf
(current-buffer))
124 (error "Can't output message to same file it's already in"))
125 ;; File has been visited, in buffer BUF.
127 (let ((inhibit-read-only t
)
128 (msg (with-no-warnings
129 (and (boundp 'rmail-current-message
)
130 rmail-current-message
))))
131 ;; If MSG is non-nil, buffer is in RMAIL mode.
133 (rmail-output-to-r-mail-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 ;; When Rmail is really installed, if we delete or rename the old Rmail
140 ;; we should do likewise with this function.
142 (defun rmail-output-to-r-mail-buffer (tembuf msg
)
143 "Copy msg in TEMBUF from BEG to END into this old R-mail BABYL buffer.
144 Do what is necessary to make babyl R-mail know about the new message.
145 Then display message number MSG."
147 ;; Turn on Auto Save mode, if it's off in this
148 ;; buffer but enabled by default.
149 (and (not buffer-auto-save-file-name
)
152 (rmail-maybe-set-message-counters)
154 (narrow-to-region (point-max) (point-max))
155 (insert-buffer-substring tembuf
)
156 (goto-char (point-min))
158 (search-backward "\n\^_")
159 (narrow-to-region (point) (point-max))
160 (rmail-count-new-messages t
)
161 (if (rmail-summary-exists)
162 (rmail-select-summary
163 (rmail-update-summary)))
164 (rmail-show-message msg
)))
166 (defun rmail-convert-to-babyl-format ()
167 (let ((count 0) (start (point-min))
168 (case-fold-search nil
)
169 (buffer-undo-list t
))
170 (goto-char (point-min))
172 (unless (looking-at "^From ")
173 (error "Invalid mbox message"))
174 (insert "\^L\n0, unseen,,\n*** EOOH ***\n")
175 (rmail-nuke-pinhead-header)
176 ;; Decode base64 or quoted printable contents, Rmail style.
177 (let* ((header-end (save-excursion
178 (and (re-search-forward "\n\n" nil t
)
181 (quoted-printable-header-field-end
184 "^content-transfer-encoding:\\(\n?[\t ]\\)*quoted-printable\\(\n?[\t ]\\)*"
186 (base64-header-field-end
188 ;; Don't decode non-text data.
191 "^content-type:\\(\n?[\t ]\\)\\(text\\|message\\)/"
195 "^content-transfer-encoding:\\(\n?[\t ]\\)*base64\\(\n?[\t ]\\)*"
198 (goto-char (point-max))
199 (if quoted-printable-header-field-end
201 (unless (mail-unquote-printable-region
202 header-end
(point) nil t t
)
203 (message "Malformed MIME quoted-printable message"))
204 ;; Change "quoted-printable" to "8bit",
205 ;; to reflect the decoding we just did.
206 (goto-char quoted-printable-header-field-end
)
207 (delete-region (point) (search-backward ":"))
209 (if base64-header-field-end
211 (when (condition-case nil
213 (base64-decode-region
216 ;; Prevent base64-decode-region
217 ;; from removing newline characters.
218 (skip-chars-backward "\n\t ")
222 ;; Change "base64" to "8bit", to reflect the
223 ;; decoding we just did.
224 (goto-char base64-header-field-end
)
225 (delete-region (point) (search-backward ":"))
226 (insert ": 8bit")))))
227 ;; Transform anything within the message text
228 ;; that might appear to be the end of a Babyl-format message.
231 (narrow-to-region start
(point))
232 (goto-char (point-min))
233 (while (search-forward "\n\^_" nil t
) ; single char
234 (replace-match "\n^_")))) ; 2 chars: "^" and "_"
235 ;; This is for malformed messages that don't end in newline.
236 ;; There shouldn't be any, but some users say occasionally
238 (or (bolp) (newline))
240 (setq last-coding-system-used nil
)
241 ;; Decode coding system, following specs in the message header,
242 ;; and record what coding system was decoded.
243 (if rmail-output-decode-coding
247 (search-forward "\n\n" nil t
)
248 (let ((case-fold-search t
))
250 rmail-mime-charset-pattern
252 (intern (downcase (match-string 1))))))
253 (rmail-decode-region start
(point) mime-charset
)))
257 (insert "X-Coding-System: "
258 (symbol-name last-coding-system-used
)
261 ;; Delete the "From ..." line, creating various other headers with
262 ;; information from it if they don't already exist. Now puts the
263 ;; original line into a mail-from: header line for debugging and for
264 ;; use by the rmail-output function.
265 (defun rmail-nuke-pinhead-header ()
268 (let ((start (point))
271 (search-forward "\n\n")
273 (goto-char (point-max))
277 (narrow-to-region start end
)
278 (let ((case-fold-search t
))
280 (setq has-from
(search-forward "\nFrom:" nil t
))
282 (setq has-date
(and (search-forward "\nDate:" nil t
) (point)))
284 (let ((case-fold-search nil
))
285 (if (re-search-forward (concat "^" rmail-unix-mail-delimiter
) nil t
)
289 ;; Keep and reformat the date if we don't
290 ;; have a Date: field.
294 "Date: \\2, \\4 \\3 \\9 \\5 "
296 ;; The timezone could be matched by group 7 or group 10.
297 ;; If neither of them matched, assume EST, since only
298 ;; Easterners would be so sloppy.
299 ;; It's a shame the substitution can't use "\\10".
301 ((/= (match-beginning 7) (match-end 7)) "\\7")
302 ((/= (match-beginning 10) (match-end 10))
303 (buffer-substring (match-beginning 10)
307 ;; Keep and reformat the sender if we don't
308 ;; have a From: field.
314 (defun rmail-output-as-mbox (file-name nomsg
&optional as-seen
)
315 "Convert the current buffer's text to mbox Babyl and output to FILE-NAME.
316 It alters the current buffer's text, so call with a temp buffer current.
317 If FILE-NAME is visited, output into its buffer instead.
318 AS-SEEN is non-nil if we are copying the message \"as seen\"."
319 (let ((case-fold-search t
)
320 mail-from mime-version content-type
)
322 ;; Preserve the Mail-From and MIME-Version fields
323 ;; even if they have been pruned.
324 (search-forward "\n\n" nil
'move
)
325 (narrow-to-region (point-min) (point))
327 (rmail-delete-unwanted-fields
328 (if rmail-enable-mime
"Mail-From"
329 "Mail-From\\|MIME-Version\\|Content-type"))
333 ;; Make sure message ends with blank line.
334 (goto-char (point-max))
337 (unless (looking-back "\n\n")
340 ;; Generate a From line from other header fields
342 (goto-char (point-min))
343 (unless (looking-at "From ")
345 (mail-strip-quoted-names
348 (goto-char (point-min))
351 (or (search-forward "\n\n" nil
)
353 (or (mail-fetch-field "from")
354 (mail-fetch-field "really-from")
355 (mail-fetch-field "sender")
357 " " (current-time-string) "\n"))
359 (let ((buf (find-buffer-visiting file-name
))
360 (tembuf (current-buffer)))
362 (let ((coding-system-for-write 'raw-text-unix
))
363 (write-region (point-min) (point-max) file-name t nomsg
))
364 (if (eq buf
(current-buffer))
365 (error "Can't output message to same file it's already in"))
366 ;; File has been visited, in buffer BUF.
368 (let ((inhibit-read-only t
)
369 (msg (and (boundp 'rmail-current-message
)
370 rmail-current-message
)))
372 (error "Can't output \"as seen\" to a visited Rmail file"))
374 (rmail-output-to-rmail-buffer tembuf msg
)
375 ;; Output file not in Rmail mode => just insert at the end.
376 (narrow-to-region (point-min) (1+ (buffer-size)))
377 (goto-char (point-max))
378 (insert-buffer-substring tembuf
)))))))
380 ;; Called only if rmail-summary-exists, which means rmailsum is loaded.
381 (declare-function rmail-update-summary
"rmailsum" (&rest ignore
))
383 (defun rmail-output-to-rmail-buffer (tembuf msg
)
384 "Copy msg in TEMBUF from BEG to END into this Rmail buffer.
385 Do what is necessary to make Rmail know about the new message.
386 Then display message number MSG."
388 (rmail-swap-buffers-maybe)
389 ;; Turn on Auto Save mode, if it's off in this
390 ;; buffer but enabled by default.
391 (and (not buffer-auto-save-file-name
)
394 (rmail-maybe-set-message-counters)
395 (narrow-to-region (point-max) (point-max))
396 (insert-buffer-substring tembuf
)
397 (rmail-count-new-messages t
)
398 (if (rmail-summary-exists)
399 (rmail-select-summary
400 (rmail-update-summary)))
401 (rmail-show-message msg
)))
403 ;;; There are functions elsewhere in Emacs that use this function;
404 ;;; look at them before you change the calling method.
406 (defun rmail-output (file-name &optional count noattribute from-gnus
)
407 "Append this message to mail file FILE-NAME.
408 This works with both mbox format and Babyl format files,
409 outputting in the appropriate format for each.
410 The default file name comes from `rmail-default-file',
411 which is updated to the name you use in this command.
413 A prefix argument COUNT says to output that many consecutive messages,
414 starting with the current one. Deleted messages are skipped and don't count.
415 When called from Lisp code, COUNT may be omitted and defaults to 1.
417 This command always outputs the complete message header,
418 even the header display is currently pruned.
420 The optional third argument NOATTRIBUTE, if non-nil, says not
421 to set the `filed' attribute, and not to display a message.
423 The optional fourth argument FROM-GNUS is set when called from GNUS."
425 (list (rmail-output-read-file-name)
426 (prefix-numeric-value current-prefix-arg
)))
427 (or count
(setq count
1))
429 (expand-file-name file-name
430 (and rmail-default-file
431 (file-name-directory rmail-default-file
))))
433 ;; Warn about creating new file.
434 (or (find-buffer-visiting file-name
)
435 (file-exists-p file-name
)
437 (concat "\"" file-name
"\" does not exist, create it? "))
438 (error "Output file does not exist"))
440 (set-buffer rmail-buffer
)
442 (let ((orig-count count
)
444 (tembuf (get-buffer-create " rmail-output"))
446 (and (file-readable-p file-name
) (mail-file-babyl-p file-name
))))
450 (with-current-buffer rmail-buffer
452 (setq beg
(rmail-msgbeg rmail-current-message
)
453 end
(rmail-msgend rmail-current-message
))
454 ;; All access to the buffer's local variables is now finished...
456 ;; ... so it is ok to go to a different buffer.
457 (if (rmail-buffers-swapped-p) (set-buffer rmail-view-buffer
))
458 (setq cur
(current-buffer))
461 (with-current-buffer tembuf
462 (insert-buffer-substring cur beg end
)
463 ;; Convert the text to one format or another and output.
465 (rmail-output-as-babyl file-name
(if noattribute
'nomsg
))
466 (rmail-output-as-mbox file-name
467 (if noattribute
'nomsg
))))))))
469 ;; Mark message as "filed".
471 (rmail-set-attribute rmail-filed-attr-index t
))
473 (setq count
(1- count
))
476 (let ((next-message-p
477 (if rmail-delete-after-output
478 (rmail-delete-forward)
480 (rmail-next-undeleted-message 1))))
481 (num-appended (- orig-count count
)))
482 (if (and (> count
0) (not next-message-p
))
483 (error "Only %d message%s appended" num-appended
484 (if (= num-appended
1) "" "s"))))))
485 (kill-buffer tembuf
))))
487 (defun rmail-output-as-seen (file-name &optional count noattribute from-gnus
)
488 "Append this message to system-inbox-format mail file named FILE-NAME.
489 A prefix argument COUNT says to output that many consecutive messages,
490 starting with the current one. Deleted messages are skipped and don't count.
491 When called from Lisp code, COUNT may be omitted and defaults to 1.
493 This outputs the message header as you see it.
495 The default file name comes from `rmail-default-file',
496 which is updated to the name you use in this command.
498 The optional third argument NOATTRIBUTE, if non-nil, says not
499 to set the `filed' attribute, and not to display a message.
501 The optional fourth argument FROM-GNUS is set when called from GNUS."
503 (list (rmail-output-read-file-name)
504 (prefix-numeric-value current-prefix-arg
)))
505 (or count
(setq count
1))
507 (expand-file-name file-name
508 (and rmail-default-file
509 (file-name-directory rmail-default-file
))))
510 (set-buffer rmail-buffer
)
512 ;; Warn about creating new file.
513 (or (find-buffer-visiting file-name
)
514 (file-exists-p file-name
)
516 (concat "\"" file-name
"\" does not exist, create it? "))
517 (error "Output file does not exist"))
519 (if (and (file-readable-p file-name
) (mail-file-babyl-p file-name
))
520 (error "Cannot output `as seen' to a Babyl file"))
522 (let ((orig-count count
)
524 (tembuf (get-buffer-create " rmail-output")))
529 ;; If operating from whole-mbox buffer, get message bounds.
530 (if (not (rmail-buffers-swapped-p))
531 (setq beg
(rmail-msgbeg rmail-current-message
)
532 end
(rmail-msgend rmail-current-message
)))
533 ;; All access to the buffer's local variables is now finished...
535 (setq cur
(current-buffer))
538 ;; If operating from the view buffer, get the bounds.
540 (setq beg
(point-min)
543 (with-current-buffer tembuf
544 (insert-buffer-substring cur beg end
)
545 ;; Convert the text to one format or another and output.
546 (rmail-output-as-mbox file-name
547 (if noattribute
'nomsg
)
550 ;; Mark message as "filed".
552 (rmail-set-attribute rmail-filed-attr-index t
))
554 (setq count
(1- count
))
557 (let ((next-message-p
558 (if rmail-delete-after-output
559 (rmail-delete-forward)
561 (rmail-next-undeleted-message 1))))
562 (num-appended (- orig-count count
)))
563 (if (and (> count
0) (not next-message-p
))
564 (error "Only %d message%s appended" num-appended
565 (if (= num-appended
1) "" "s"))))))
566 (kill-buffer tembuf
))))
570 (defun rmail-output-body-to-file (file-name)
571 "Write this message body to the file FILE-NAME.
572 FILE-NAME defaults, interactively, from the Subject field of the message."
575 (or (mail-fetch-field "Subject")
576 rmail-default-body-file
)))
577 (list (setq rmail-default-body-file
579 "Output message body to file: "
580 (and default-file
(file-name-directory default-file
))
582 nil default-file
)))))
584 (expand-file-name file-name
585 (and rmail-default-body-file
586 (file-name-directory rmail-default-body-file
))))
588 (goto-char (point-min))
589 (search-forward "\n\n")
590 (and (file-exists-p file-name
)
591 (not (y-or-n-p (format "File %s exists; overwrite? " file-name
)))
592 (error "Operation aborted"))
593 (write-region (point) (point-max) file-name
))
594 (if rmail-delete-after-output
595 (rmail-delete-forward)))
597 ;; arch-tag: 4059abf0-f249-4be4-8e0d-602d370d01d1
598 ;;; rmailout.el ends here