rmailout.el 15.2 KB
Newer Older
1
;;; rmailout.el --- "RMAIL" mail reader for Emacs: output message to a file
Eric S. Raymond's avatar
Eric S. Raymond committed
2

3
;; Copyright (C) 1985, 1987, 1993, 1994, 2001, 2002, 2003, 2004,
Glenn Morris's avatar
Glenn Morris committed
4
;;   2005, 2006, 2007, 2008 Free Software Foundation, Inc.
Eric S. Raymond's avatar
Eric S. Raymond committed
5

Eric S. Raymond's avatar
Eric S. Raymond committed
6
;; Maintainer: FSF
Eric S. Raymond's avatar
Eric S. Raymond committed
7
;; Keywords: mail
Eric S. Raymond's avatar
Eric S. Raymond committed
8

root's avatar
root committed
9 10
;; This file is part of GNU Emacs.

11
;; GNU Emacs is free software: you can redistribute it and/or modify
root's avatar
root committed
12
;; it under the terms of the GNU General Public License as published by
13 14
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
root's avatar
root committed
15 16 17 18 19 20 21

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; 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/>.
root's avatar
root committed
23

24 25
;;; Commentary:

Eric S. Raymond's avatar
Eric S. Raymond committed
26
;;; Code:
root's avatar
root committed
27

28
(require 'rmail)
Richard M. Stallman's avatar
Richard M. Stallman committed
29
(provide 'rmailout)
30

31
;;;###autoload
Richard M. Stallman's avatar
Richard M. Stallman committed
32
(defcustom rmail-output-file-alist nil
33
  "*Alist matching regexps to suggested output Rmail files.
34
This is a list of elements of the form (REGEXP . NAME-EXP).
35
The suggestion is taken if REGEXP matches anywhere in the message buffer.
36 37
NAME-EXP may be a string constant giving the file name to use,
or more generally it may be any kind of expression that returns
Richard M. Stallman's avatar
Richard M. Stallman committed
38 39 40 41 42 43
a file name as a string."
  :type '(repeat (cons regexp
		       (choice :value ""
			       (string :tag "File Name")
			       sexp)))
  :group 'rmail-output)
44

Richard M. Stallman's avatar
Richard M. Stallman committed
45 46 47 48 49 50 51 52 53
(defun rmail-output-read-rmail-file-name ()
  "Read the file name to use for `rmail-output-to-rmail-file'.
Set `rmail-default-rmail-file' to this name as well as returning it."
  (let ((default-file
	  (let (answer tail)
	    (setq tail rmail-output-file-alist)
	    ;; Suggest a file based on a pattern match.
	    (while (and tail (not answer))
	      (save-excursion
54
		(set-buffer rmail-buffer)
Richard M. Stallman's avatar
Richard M. Stallman committed
55 56 57 58 59 60 61 62 63
		(goto-char (point-min))
		(if (re-search-forward (car (car tail)) nil t)
		    (setq answer (eval (cdr (car tail)))))
		(setq tail (cdr tail))))
	    ;; If no suggestions, use same file as last time.
	    (expand-file-name (or answer rmail-default-rmail-file)))))
    (let ((read-file
	   (expand-file-name
	    (read-file-name
64
	     (concat "Output message to Rmail file (default "
Richard M. Stallman's avatar
Richard M. Stallman committed
65
		     (file-name-nondirectory default-file)
66
		     "): ")
Richard M. Stallman's avatar
Richard M. Stallman committed
67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95
	     (file-name-directory default-file)
	     (abbreviate-file-name default-file))
	    (file-name-directory default-file))))
      ;; If the user enters just a directory,
      ;; use the name within that directory chosen by the default.
      (setq rmail-default-rmail-file
	    (if (file-directory-p read-file)
		(expand-file-name (file-name-nondirectory default-file)
				  read-file)
	      read-file)))))

(defun rmail-output-read-file-name ()
  "Read the file name to use for `rmail-output'.
Set `rmail-default-file' to this name as well as returning it."
  (let ((default-file
	  (let (answer tail)
	    (setq tail rmail-output-file-alist)
	    ;; Suggest a file based on a pattern match.
	    (while (and tail (not answer))
	      (save-excursion
		(goto-char (point-min))
		(if (re-search-forward (car (car tail)) nil t)
		    (setq answer (eval (cdr (car tail)))))
		(setq tail (cdr tail))))
	    ;; If no suggestion, use same file as last time.
	    (or answer rmail-default-file))))
    (let ((read-file
	   (expand-file-name
	    (read-file-name
96
	     (concat "Output message to Unix mail file (default "
Richard M. Stallman's avatar
Richard M. Stallman committed
97
		     (file-name-nondirectory default-file)
98
		     "): ")
Richard M. Stallman's avatar
Richard M. Stallman committed
99 100 101 102 103 104 105 106 107 108 109
	     (file-name-directory default-file)
	     (abbreviate-file-name default-file))
	    (file-name-directory default-file))))
      (setq rmail-default-file
	    (if (file-directory-p read-file)
		(expand-file-name (file-name-nondirectory default-file)
				  read-file)
	      (expand-file-name
	       (or read-file (file-name-nondirectory default-file))
	       (file-name-directory default-file)))))))

110 111
(declare-function rmail-update-summary "rmailsum" (&rest ignore))

112 113
;;; There are functions elsewhere in Emacs that use this function;
;;; look at them before you change the calling method.
114
;;;###autoload
115
(defun rmail-output-to-rmail-file (file-name &optional count stay)
root's avatar
root committed
116 117 118 119
  "Append the current message to an Rmail file named FILE-NAME.
If the file does not exist, ask if it should be created.
If file is being visited, the message is appended to the Emacs
buffer visiting that file.
120 121
If the file exists and is not an Rmail file, the message is
appended in inbox format, the same way `rmail-output' does it.
122

123
The default file name comes from `rmail-default-rmail-file',
Richard M. Stallman's avatar
Richard M. Stallman committed
124 125
which is updated to the name you use in this command.

126
A prefix argument COUNT says to output that many consecutive messages,
127 128
starting with the current one.  Deleted messages are skipped and don't count.

129 130
If the optional argument STAY is non-nil, then leave the last filed
message up instead of moving forward to the next non-deleted message."
131
  (interactive
Richard M. Stallman's avatar
Richard M. Stallman committed
132 133
   (list (rmail-output-read-rmail-file-name)
	 (prefix-numeric-value current-prefix-arg)))
134
  (or count (setq count 1))
Jim Blandy's avatar
Jim Blandy committed
135 136
  (setq file-name
	(expand-file-name file-name
137
			  (file-name-directory rmail-default-rmail-file)))
138
  (if (and (file-readable-p file-name) (not (mail-file-babyl-p file-name)))
139 140 141
      (rmail-output file-name count)
    (rmail-maybe-set-message-counters)
    (setq file-name (abbreviate-file-name file-name))
142
    (or (find-buffer-visiting file-name)
143 144 145 146
	(file-exists-p file-name)
	(if (yes-or-no-p
	     (concat "\"" file-name "\" does not exist, create it? "))
	    (let ((file-buffer (create-file-buffer file-name)))
root's avatar
root committed
147
	      (save-excursion
148 149
		(set-buffer file-buffer)
		(rmail-insert-rmail-file-header)
150 151 152 153
		(let ((require-final-newline nil)
		      (coding-system-for-write
		       (or rmail-file-coding-system
			   'emacs-mule-unix)))
154 155 156 157 158 159 160
		  (write-region (point-min) (point-max) file-name t 1)))
	      (kill-buffer file-buffer))
	  (error "Output file does not exist")))
    (while (> count 0)
      (let (redelete)
	(unwind-protect
	    (progn
161
	      (set-buffer rmail-buffer)
162 163 164 165 166 167
	      ;; Temporarily turn off Deleted attribute.
	      ;; Do this outside the save-restriction, since it would
	      ;; shift the place in the buffer where the visible text starts.
	      (if (rmail-message-deleted-p rmail-current-message)
		  (progn (setq redelete t)
			 (rmail-set-attribute "deleted" nil)))
168 169 170 171
	      (save-restriction
		(widen)
		;; Decide whether to append to a file or to an Emacs buffer.
		(save-excursion
172
		  (let ((buf (find-buffer-visiting file-name))
173 174
			(cur (current-buffer))
			(beg (1+ (rmail-msgbeg rmail-current-message)))
175 176 177 178
			(end (1+ (rmail-msgend rmail-current-message)))
			(coding-system-for-write
			 (or rmail-file-coding-system
			     'emacs-mule-unix)))
179
		    (if (not buf)
180 181 182 183 184 185 186 187 188 189 190
			;; Output to a file.
			(if rmail-fields-not-to-output
			    ;; Delete some fields while we output.
			    (let ((obuf (current-buffer)))
			      (set-buffer (get-buffer-create " rmail-out-temp"))
			      (insert-buffer-substring obuf beg end)
			      (rmail-delete-unwanted-fields)
			      (append-to-file (point-min) (point-max) file-name)
			      (set-buffer obuf)
			      (kill-buffer (get-buffer " rmail-out-temp")))
			  (append-to-file beg end file-name))
191 192 193 194 195 196 197 198 199 200
		      (if (eq buf (current-buffer))
			  (error "Can't output message to same file it's already in"))
		      ;; File has been visited, in buffer BUF.
		      (set-buffer buf)
		      (let ((buffer-read-only nil)
			    (msg (and (boundp 'rmail-current-message)
				      rmail-current-message)))
			;; If MSG is non-nil, buffer is in RMAIL mode.
			(if msg
			    (progn
201 202 203 204 205
			      ;; Turn on auto save mode, if it's off in this
			      ;; buffer but enabled by default.
			      (and (not buffer-auto-save-file-name)
				   auto-save-default
				   (auto-save-mode t))
206 207 208 209 210 211 212 213
			      (rmail-maybe-set-message-counters)
			      (widen)
			      (narrow-to-region (point-max) (point-max))
			      (insert-buffer-substring cur beg end)
			      (goto-char (point-min))
			      (widen)
			      (search-backward "\n\^_")
			      (narrow-to-region (point) (point-max))
214
			      (rmail-delete-unwanted-fields)
215
			      (rmail-count-new-messages t)
216 217 218
			      (if (rmail-summary-exists)
				  (rmail-select-summary
				    (rmail-update-summary)))
219
			      (rmail-show-message msg))
220 221 222 223 224
			  ;; Output file not in rmail mode => just insert at the end.
			  (narrow-to-region (point-min) (1+ (buffer-size)))
			  (goto-char (point-max))
			  (insert-buffer-substring cur beg end)
			  (rmail-delete-unwanted-fields)))))))
225 226 227 228
	      (rmail-set-attribute "filed" t))
	  (if redelete (rmail-set-attribute "deleted" t))))
      (setq count (1- count))
      (if rmail-delete-after-output
229
	  (unless
230 231 232 233
	      (if (and (= count 0) stay)
		  (rmail-delete-message)
		(rmail-delete-forward))
	    (setq count 0))
234
	(if (> count 0)
235
	    (unless
236 237
		(if (not stay) (rmail-next-undeleted-message 1))
	      (setq count 0)))))))
238

239
;;;###autoload
Richard M. Stallman's avatar
Richard M. Stallman committed
240 241 242 243 244
(defcustom rmail-fields-not-to-output nil
  "*Regexp describing fields to exclude when outputting a message to a file."
  :type '(choice (const :tag "None" nil)
		 regexp)
  :group 'rmail-output)
245 246 247 248 249

;; Delete from the buffer header fields we don't want output.
;; NOT-RMAIL if t means this buffer does not have the full header
;; and *** EOOH *** that a message in an Rmail file has.
(defun rmail-delete-unwanted-fields (&optional not-rmail)
250
  (if rmail-fields-not-to-output
251 252 253 254 255 256 257 258 259 260 261 262
      (save-excursion
	(goto-char (point-min))
	;; Find the end of the header.
	(if (and (or not-rmail (search-forward "\n*** EOOH ***\n" nil t))
		 (search-forward "\n\n" nil t))
	    (let ((end (point-marker)))
	      (goto-char (point-min))
	      (while (re-search-forward rmail-fields-not-to-output end t)
		(beginning-of-line)
		(delete-region (point)
			       (progn (forward-line 1) (point)))))))))

263 264
;;; There are functions elsewhere in Emacs that use this function;
;;; look at them before you change the calling method.
265
;;;###autoload
266
(defun rmail-output (file-name &optional count noattribute from-gnus)
Richard M. Stallman's avatar
Richard M. Stallman committed
267
  "Append this message to system-inbox-format mail file named FILE-NAME.
268
A prefix argument COUNT says to output that many consecutive messages,
269
starting with the current one.  Deleted messages are skipped and don't count.
270
When called from lisp code, COUNT may be omitted and defaults to 1.
271

272 273 274 275
If the pruned message header is shown on the current message, then
messages will be appended with pruned headers; otherwise, messages
will be appended with their original headers.

Richard M. Stallman's avatar
Richard M. Stallman committed
276
The default file name comes from `rmail-default-file',
Richard M. Stallman's avatar
Richard M. Stallman committed
277 278
which is updated to the name you use in this command.

279
The optional third argument NOATTRIBUTE, if non-nil, says not
280 281 282
to set the `filed' attribute, and not to display a message.

The optional fourth argument FROM-GNUS is set when called from GNUS."
root's avatar
root committed
283
  (interactive
Richard M. Stallman's avatar
Richard M. Stallman committed
284 285
   (list (rmail-output-read-file-name)
	 (prefix-numeric-value current-prefix-arg)))
286
  (or count (setq count 1))
Jim Blandy's avatar
Jim Blandy committed
287 288
  (setq file-name
	(expand-file-name file-name
289 290
			  (and rmail-default-file
			       (file-name-directory rmail-default-file))))
291
  (if (and (file-readable-p file-name) (mail-file-babyl-p file-name))
292
      (rmail-output-to-rmail-file file-name count)
293
    (set-buffer rmail-buffer)
294 295 296 297 298
    (let ((orig-count count)
	  (rmailbuf (current-buffer))
	  (case-fold-search t)
	  (tembuf (get-buffer-create " rmail-output"))
	  (original-headers-p
299
	   (and (not from-gnus)
300
		(save-excursion
301 302 303 304 305
		  (save-restriction
		    (narrow-to-region (rmail-msgbeg rmail-current-message) (point-max))
		    (goto-char (point-min))
		    (forward-line 1)
		    (= (following-char) ?0)))))
306
	  header-beginning
307
	  mail-from mime-version content-type)
308
      (while (> count 0)
309 310
	;; Preserve the Mail-From and MIME-Version fields
	;; even if they have been pruned.
311
	(or from-gnus
312 313 314 315 316 317 318
	    (save-excursion
	      (save-restriction
		(widen)
		(goto-char (rmail-msgbeg rmail-current-message))
		(setq header-beginning (point))
		(search-forward "\n*** EOOH ***\n")
		(narrow-to-region header-beginning (point))
319 320 321 322
		(setq mail-from (mail-fetch-field "Mail-From"))
		(unless rmail-enable-mime
		  (setq mime-version (mail-fetch-field "MIME-Version")
			content-type (mail-fetch-field "Content-type"))))))
323 324 325 326
	(save-excursion
	  (set-buffer tembuf)
	  (erase-buffer)
	  (insert-buffer-substring rmailbuf)
327 328 329 330 331 332 333 334 335 336 337 338 339 340
	  (when rmail-enable-mime
	    (if original-headers-p
		(delete-region (goto-char (point-min))
			       (if (search-forward "\n*** EOOH ***\n")
				   (match-end 0)))
	      (goto-char (point-min))
	      (forward-line 2)
	      (delete-region (point-min)(point))
	      (search-forward "\n*** EOOH ***\n")
	      (delete-region (match-beginning 0)
			     (if (search-forward "\n\n")
				 (1- (match-end 0)))))
	    (setq buffer-file-coding-system (or rmail-file-coding-system
						'raw-text)))
341
	  (rmail-delete-unwanted-fields t)
342
	  (or (bolp) (insert "\n"))
343
	  (goto-char (point-min))
344 345 346 347 348 349 350 351
	  (if mail-from
	      (insert mail-from "\n")
	    (insert "From "
		    (mail-strip-quoted-names (or (mail-fetch-field "from")
						 (mail-fetch-field "really-from")
						 (mail-fetch-field "sender")
						 "unknown"))
		    " " (current-time-string) "\n"))
352 353 354 355 356
	  (when mime-version
	    (insert "MIME-Version: " mime-version)
	    ;; Some malformed MIME messages set content-type to nil.
	    (when content-type
	      (insert "\nContent-type: " content-type "\n")))
357 358 359
	  ;; ``Quote'' "\nFrom " as "\n>From "
	  ;;  (note that this isn't really quoting, as there is no requirement
	  ;;   that "\n[>]+From " be quoted in the same transparent way.)
360 361 362 363
	  (let ((case-fold-search nil))
	    (while (search-forward "\nFrom " nil t)
	      (forward-char -5)
	      (insert ?>)))
364 365
	  (write-region (point-min) (point-max) file-name t
			(if noattribute 'nomsg)))
366 367 368 369
	(or noattribute
	    (if (equal major-mode 'rmail-mode)
		(rmail-set-attribute "filed" t)))
	(setq count (1- count))
370 371 372 373 374 375 376 377 378 379
	(or from-gnus
	    (let ((next-message-p
		   (if rmail-delete-after-output
		       (rmail-delete-forward)
		     (if (> count 0)
			 (rmail-next-undeleted-message 1))))
		  (num-appended (- orig-count count)))
	      (if (and next-message-p original-headers-p)
		  (rmail-toggle-header))
	      (if (and (> count 0) (not next-message-p))
380
		  (progn
Deepak Goel's avatar
Deepak Goel committed
381
		    (error "%s"
382 383 384 385 386
		     (save-excursion
		       (set-buffer rmailbuf)
		       (format "Only %d message%s appended" num-appended
			       (if (= num-appended 1) "" "s"))))
		    (setq count 0))))))
387
      (kill-buffer tembuf))))
Eric S. Raymond's avatar
Eric S. Raymond committed
388

389
;;;###autoload
390
(defun rmail-output-body-to-file (file-name)
391 392 393 394
  "Write this message body to the file FILE-NAME.
FILE-NAME defaults, interactively, from the Subject field of the message."
  (interactive
   (let ((default-file
395 396 397 398 399 400 401 402 403 404 405 406
	   (or (mail-fetch-field "Subject")
	       rmail-default-body-file)))
     (list (setq rmail-default-body-file
		 (read-file-name
		  "Output message body to file: "
		  (and default-file (file-name-directory default-file))
		  default-file
		  nil default-file)))))
  (setq file-name
	(expand-file-name file-name
			  (and rmail-default-body-file
			       (file-name-directory rmail-default-body-file))))
407 408 409
  (save-excursion
    (goto-char (point-min))
    (search-forward "\n\n")
410
    (and (file-exists-p file-name)
411
	 (not (y-or-n-p (format "File %s exists; overwrite? " file-name)))
412
	 (error "Operation aborted"))
413 414 415 416 417 418
    (write-region (point) (point-max) file-name)
    (if (equal major-mode 'rmail-mode)
	(rmail-set-attribute "stored" t)))
  (if rmail-delete-after-output
      (rmail-delete-forward)))

419
;; arch-tag: 447117c6-1a9a-4b88-aa43-3101b043e3a4
Eric S. Raymond's avatar
Eric S. Raymond committed
420
;;; rmailout.el ends here