Commit | Line | Data |
---|---|---|
e131541f PR |
1 | ;;; pmailout.el --- "PMAIL" mail reader for Emacs: output message to a file. |
2 | ||
3 | ;; Copyright (C) 1985, 1987, 1993, 1994, 2001, 2002, 2003, 2004, | |
4 | ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. | |
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 | ||
28 | (provide 'pmailout) | |
29 | ||
30 | (eval-when-compile | |
31 | (require 'pmail) | |
32 | (require 'pmaildesc)) | |
33 | ||
34 | ;;;###autoload | |
35 | (defcustom pmail-output-file-alist nil | |
36 | "*Alist matching regexps to suggested output Pmail files. | |
37 | This is a list of elements of the form (REGEXP . NAME-EXP). | |
38 | The suggestion is taken if REGEXP matches anywhere in the message buffer. | |
39 | NAME-EXP may be a string constant giving the file name to use, | |
40 | or more generally it may be any kind of expression that returns | |
41 | a file name as a string." | |
42 | :type '(repeat (cons regexp | |
43 | (choice :value "" | |
44 | (string :tag "File Name") | |
45 | sexp))) | |
46 | :group 'pmail-output) | |
47 | ||
48 | ;;;###autoload | |
49 | (defcustom pmail-fields-not-to-output nil | |
50 | "*Regexp describing fields to exclude when outputting a message to a file." | |
51 | :type '(choice (const :tag "None" nil) | |
52 | regexp) | |
53 | :group 'pmail-output) | |
54 | ||
55 | (defun pmail-output-read-file-name () | |
56 | "Read the file name to use for `pmail-output'. | |
57 | Set `pmail-default-file' to this name as well as returning it." | |
58 | (let* ((default-file | |
59 | (with-current-buffer pmail-buffer | |
60 | (expand-file-name | |
61 | (or (catch 'answer | |
62 | (dolist (i pmail-output-file-alist) | |
63 | (goto-char (point-min)) | |
64 | (when (re-search-forward (car i) nil t) | |
65 | (throw 'answer (eval (cdr i)))))) | |
66 | pmail-default-file)))) | |
67 | (read-file | |
68 | (expand-file-name | |
69 | (read-file-name | |
70 | (concat "Output message to Pmail (mbox) file: (default " | |
71 | (file-name-nondirectory default-file) "): ") | |
72 | (file-name-directory default-file) | |
73 | (abbreviate-file-name default-file)) | |
74 | (file-name-directory default-file)))) | |
75 | (setq pmail-default-file | |
76 | (if (file-directory-p read-file) | |
77 | (expand-file-name | |
78 | (file-name-nondirectory default-file) read-file) | |
79 | (expand-file-name | |
80 | (or read-file (file-name-nondirectory default-file)) | |
81 | (file-name-directory default-file)))))) | |
82 | ||
83 | (declare-function pmail-update-summary "pmailsum" (&rest ignore)) | |
84 | ||
85 | ;;; There are functions elsewhere in Emacs that use this function; | |
86 | ;;; look at them before you change the calling method. | |
87 | ;;;###autoload | |
88 | (defun pmail-output-to-pmail-file (file-name &optional count stay) | |
89 | "Append the current message to an Pmail (mbox) file named FILE-NAME. | |
90 | If the file does not exist, ask if it should be created. | |
91 | If file is being visited, the message is appended to the Emacs | |
92 | buffer visiting that file. | |
93 | If the file exists and is not an Pmail file, the message is | |
94 | appended in inbox format, the same way `pmail-output' does it. | |
95 | ||
96 | The default file name comes from `pmail-default-pmail-file', | |
97 | which is updated to the name you use in this command. | |
98 | ||
99 | A prefix argument COUNT says to output that many consecutive messages, | |
100 | starting with the current one. Deleted messages are skipped and don't count. | |
101 | ||
102 | If the optional argument STAY is non-nil, then leave the last filed | |
103 | message up instead of moving forward to the next non-deleted message." | |
104 | (interactive (list (pmail-output-read-file-name) | |
105 | (prefix-numeric-value current-prefix-arg))) | |
106 | ;; Use the 'pmail-output function to perform the output. | |
107 | (pmail-output file-name count nil nil) | |
108 | ;; Deal with the next message | |
109 | (if pmail-delete-after-output | |
110 | (unless (if (and (= count 0) stay) | |
111 | (pmail-delete-message) | |
112 | (pmail-delete-forward)) | |
113 | (setq count 0)) | |
114 | (when (> count 0) | |
115 | (unless (when (not stay) | |
116 | (pmail-next-undeleted-message 1)) | |
117 | (setq count 0))))) | |
118 | ||
119 | (defun pmail-delete-unwanted-fields () | |
120 | "Delete from the buffer header fields we don't want output." | |
121 | (when pmail-fields-not-to-output | |
122 | (save-excursion | |
123 | (let ((limit (pmail-header-get-limit)) | |
124 | (inhibit-point-motion-hooks t) | |
125 | start) | |
126 | (goto-char (point-min)) | |
127 | (while (re-search-forward pmail-fields-not-to-output limit t) | |
128 | (forward-line 0) | |
129 | (setq start (point)) | |
130 | (while (progn (forward-line 1) (looking-at "[ \t]+")) | |
131 | (goto-char (line-end-position))) | |
132 | (delete-region start (point))))))) | |
133 | ||
134 | ;;; There are functions elsewhere in Emacs that use this function; | |
135 | ;;; look at them before you change the calling method. | |
136 | ;;;###autoload | |
137 | (defun pmail-output (file-name &optional count noattribute from-gnus) | |
138 | "Append this message to system-inbox-format mail file named FILE-NAME. | |
139 | A prefix argument COUNT says to output that many consecutive messages, | |
140 | starting with the current one. Deleted messages are skipped and don't count. | |
141 | When called from lisp code, COUNT may be omitted and defaults to 1. | |
142 | ||
143 | If the pruned message header is shown on the current message, then | |
144 | messages will be appended with pruned headers; otherwise, messages | |
145 | will be appended with their original headers. | |
146 | ||
147 | The default file name comes from `pmail-default-file', | |
148 | which is updated to the name you use in this command. | |
149 | ||
150 | The optional third argument NOATTRIBUTE, if non-nil, says not | |
151 | to set the `filed' attribute, and not to display a message. | |
152 | ||
153 | The optional fourth argument FROM-GNUS is set when called from GNUS." | |
154 | (interactive | |
155 | (list (pmail-output-read-file-name) | |
156 | (prefix-numeric-value current-prefix-arg))) | |
157 | (or count (setq count 1)) | |
158 | (setq file-name | |
159 | (expand-file-name file-name | |
160 | (and pmail-default-file | |
161 | (file-name-directory pmail-default-file)))) | |
162 | (if (and (file-readable-p file-name) (mail-file-babyl-p file-name)) | |
163 | (error "BABYL output not supported.") | |
164 | (with-current-buffer pmail-buffer | |
165 | (let ((orig-count count) | |
166 | (pmailbuf (current-buffer)) | |
167 | (destbuf (find-buffer-visiting file-name)) | |
168 | (case-fold-search t)) | |
169 | (while (> count 0) | |
170 | (with-temp-buffer | |
171 | (insert-buffer-substring pmailbuf) | |
172 | ;; ensure we can write without barfing on exotic characters | |
173 | (setq buffer-file-coding-system | |
174 | (or pmail-file-coding-system 'raw-text)) | |
175 | ;; prune junk headers | |
176 | (pmail-delete-unwanted-fields) | |
177 | (if (not destbuf) | |
178 | ;; The destination file is not being visited, just write | |
179 | ;; out the processed message. | |
180 | (write-region (point-min) (point-max) file-name | |
181 | t (when noattribute 'nomsg)) | |
182 | ;; The destination file is being visited. Update it. | |
183 | (let ((msg-string (buffer-string))) | |
184 | (with-current-buffer destbuf | |
185 | ;; Determine if the destination file is an Pmail file. | |
186 | (let ((buffer-read-only nil) | |
187 | (dest-current-message | |
188 | (and (boundp 'pmail-current-message) | |
189 | pmail-current-message))) | |
190 | (if dest-current-message | |
191 | ;; The buffer is an Pmail buffer. Append the | |
192 | ;; message. | |
193 | (progn | |
194 | (widen) | |
195 | (narrow-to-region (point-max) (point-max)) | |
196 | (insert msg-string) | |
197 | (insert "\n") | |
198 | (pmail-process-new-messages) | |
199 | (pmail-show-message dest-current-message)) | |
200 | ;; The destination file is not an Pmail file, just | |
201 | ;; insert at the end. | |
202 | (goto-char (point-max)) | |
203 | (insert msg-string))))))) | |
204 | (unless noattribute | |
205 | (when (equal major-mode 'pmail-mode) | |
206 | (pmail-set-attribute "filed" t) | |
207 | (pmail-header-hide-headers))) | |
208 | (setq count (1- count)) | |
209 | (unless from-gnus | |
210 | (let ((next-message-p | |
211 | (if pmail-delete-after-output | |
212 | (pmail-delete-forward) | |
213 | (when (> count 0) | |
214 | (pmail-next-undeleted-message 1)))) | |
215 | (num-appended (- orig-count count))) | |
216 | (when (and (> count 0) (not next-message-p)) | |
217 | (error (format "Only %d message%s appended" num-appended | |
218 | (if (= num-appended 1) "" "s"))) | |
219 | (setq count 0))))))))) | |
220 | ||
221 | ;;;###autoload | |
222 | (defun pmail-output-body-to-file (file-name) | |
223 | "Write this message body to the file FILE-NAME. | |
224 | FILE-NAME defaults, interactively, from the Subject field of the message." | |
225 | (interactive | |
226 | (let ((default-file (or (mail-fetch-field "Subject") | |
227 | pmail-default-body-file))) | |
228 | (list (setq pmail-default-body-file | |
229 | (read-file-name | |
230 | "Output message body to file: " | |
231 | (and default-file (file-name-directory default-file)) | |
232 | default-file | |
233 | nil default-file))))) | |
234 | (setq file-name | |
235 | (expand-file-name | |
236 | file-name | |
237 | (and pmail-default-body-file | |
238 | (file-name-directory pmail-default-body-file)))) | |
239 | (save-excursion | |
240 | (goto-char (point-min)) | |
241 | (search-forward "\n\n") | |
242 | (and (file-exists-p file-name) | |
243 | (not (y-or-n-p (message "File %s exists; overwrite? " file-name))) | |
244 | (error "Operation aborted")) | |
245 | (write-region (point) (point-max) file-name) | |
246 | (when (equal major-mode 'pmail-mode) | |
247 | (pmail-desc-set-attribute pmail-desc-stored-index | |
248 | t pmail-current-message))) | |
249 | (when pmail-delete-after-output | |
250 | (pmail-delete-forward))) | |
251 | ||
0faeefbb | 252 | ;; arch-tag: 4059abf0-f249-4be4-8e0d-602d370d01d1 |
e131541f | 253 | ;;; pmailout.el ends here |