1 ;;; gnus-soup.el --- SOUP packet writing support for Gnus
2 ;; Copyright (C) 1995 Free Software Foundation, Inc.
4 ;; Author: Per Abrahamsen <abraham@iesd.auc.dk>
5 ;; Keywords: news, mail
7 ;; This file is part of GNU Emacs.
9 ;; GNU Emacs is free software; you can redistribute it and/or modify
10 ;; it under the terms of the GNU General Public License as published by
11 ;; the Free Software Foundation; either version 2, or (at your option)
14 ;; GNU Emacs is distributed in the hope that it will be useful,
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 ;; GNU General Public License for more details.
19 ;; You should have received a copy of the GNU General Public License
20 ;; along with GNU Emacs; see the file COPYING. If not, write to
21 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
25 ;; This file contain support for storing articles in SOUP format from
26 ;; within Gnus. Support for reading SOUP packets is provided in
29 ;; SOUP is a format for offline reading of news and mail. See the
30 ;; file `soup12.zip' in one of the Simtel mirrors
31 ;; (e.g. `ftp.funet.fi') for the specification of SOUP.
33 ;; Only a subset of the SOUP protocol is supported, and the minimal
34 ;; conformance requirements in the SOUP document is *not* meet.
35 ;; Most annoyingly, replying and posting are not supported.
38 ;; (require 'gnus-soup)
39 ;; in your `.emacs' file to enable the SOUP support.
41 ;; Type `V o s' to add articles to the SOUP packet.
42 ;; Use a prefix argument or the process mark to add multiple articles.
44 ;; The variable `gnus-soup-directory' should point to the directory
45 ;; where you want to store the SOUP component files. You must
46 ;; manually `zip' the directory to generate a conforming SOUP packet.
48 ;; Add `nnsoup' to `gnus-secondary-select-methods' in order to read a
49 ;; SOUP packet. The variable `nnmail-directory' should point to the
50 ;; directory containing the unziped SOUP packet.
52 ;; Check out `uqwk' or `yarn' for two alterative solutions to
53 ;; generating or reading SOUP packages respectively, they should both
54 ;; be available at a Simtel mirror near you. There are plenty of
55 ;; other SOUP-aware programs available as well, look in the group
56 ;; `alt.usenet.offline-reader' and its FAQ for more information.
58 ;; Since `gnus-soup.el' does not fulfill the minimal conformance
59 ;; requirements, expect some problems when using other SOUP packeges.
60 ;; More importantly, the author haven't tested any of them.
70 (defvar gnus-soup-directory "~/SOUP/"
71 "*Directory containing unpacked SOUP packet.")
73 (defvar gnus-soup-prefix-file "gnus-prefix"
74 "*Name of the file where Gnus stores the last used prefix.")
76 (defvar gnus-soup-packer "tar cf - %s | gzip > $HOME/Soupout%d.tgz"
77 "Format string command for packing a SOUP packet.
78 The SOUP files will be inserted where the %s is in the string.
79 This string MUST contain both %s and %d. The file number will be
80 inserted where %d appears.")
82 ;;; Internal Variables:
84 (defvar gnus-soup-encoding-type ?n
86 `n' is news format, `m' is Unix mbox format, and `M' is MMDF mailbox
89 (defvar gnus-soup-index-type ?c
91 `n' means no index file and `c' means standard Cnews overview
94 (defvar gnus-soup-group-type ?u
95 "*Soup message area type.
96 `u' is unknown, `m' is private mail, and `n' is news.
97 Gnus will determine by itself what type to use in what group, so
98 setting this variable won't do much.")
100 (defconst gnus-soup-areas nil)
101 (defvar gnus-soup-last-prefix nil)
102 (defvar gnus-soup-buffers nil)
106 (defun gnus-soup-add-article (n)
107 "Add the current article to SOUP packet.
108 If N is a positive number, add the N next articles.
109 If N is a negative number, add the N previous articles.
110 If N is nil and any articles have been marked with the process mark,
111 move those articles instead."
113 (gnus-set-global-variables)
114 (add-hook 'gnus-exit-gnus-hook 'gnus-soup-save)
115 (or (file-directory-p gnus-soup-directory)
116 (gnus-make-directory gnus-soup-directory))
117 (let* ((articles (gnus-summary-work-articles n))
118 (tmp-buf (get-buffer-create "*soup work*"))
119 (prefix (aref (gnus-soup-area gnus-newsgroup-name) 0))
120 (msg-buf (find-file-noselect
121 (concat gnus-soup-directory prefix ".MSG")))
122 (idx-buf (find-file-noselect
123 (concat gnus-soup-directory prefix ".IDX")))
124 from head-line beg type headers)
125 (setq gnus-soup-buffers (cons msg-buf (cons idx-buf gnus-soup-buffers)))
126 (buffer-disable-undo tmp-buf)
127 (buffer-disable-undo msg-buf)
128 (buffer-disable-undo idx-buf)
131 ;; Put the article in a buffer.
133 (gnus-request-article-this-buffer
134 (car articles) gnus-newsgroup-name)
135 ;; Make sure the last char in the buffer is a newline.
136 (goto-char (point-max))
137 (or (= (current-column) 0)
140 (goto-char (point-min))
142 (mail-strip-quoted-names
143 (or (mail-fetch-field "from")
144 (mail-fetch-field "really-from")
145 (mail-fetch-field "sender"))))
146 (goto-char (point-min))
147 ;; Depending on what encoding is supposed to be used, we make
151 ((= gnus-soup-encoding-type ?n)
152 (format "#! rnews %d\n" (buffer-size)))
153 ((= gnus-soup-encoding-type ?m)
154 (while (search-forward "\nFrom " nil t)
155 (replace-match "\n>From " t t))
156 (concat "From " (or from "unknown")
157 " " (current-time-string) "\n"))
158 ((= gnus-soup-encoding-type ?M)
160 (t (error "Unsupported type: %c" gnus-soup-encoding-type))))
161 ;; Find the header of the article.
162 (set-buffer gnus-summary-buffer)
163 (setq headers (gnus-get-header-by-number (car articles)))
164 ;; Insert the soup header and the article in the MSG buf.
166 (goto-char (point-max))
169 (insert-buffer tmp-buf)
170 ;; Insert the index in the IDX buf.
171 (cond ((= gnus-soup-index-type ?c)
173 (gnus-soup-insert-idx beg headers))
174 ((/= gnus-soup-index-type ?n)
175 (error "Unknown index type: %c" type)))
176 (set-buffer gnus-summary-buffer)
177 (gnus-summary-remove-process-mark (car articles))
178 (gnus-summary-mark-as-read (car articles) "F")
179 (setq articles (cdr articles)))
180 (kill-buffer tmp-buf))))
182 (defun gnus-soup-group-brew (group)
183 (let ((gnus-expert-user t)
184 (gnus-large-newsgroup nil))
185 (and (gnus-summary-read-group group)
186 (let ((gnus-newsgroup-processable
187 (gnus-sorted-complement
188 gnus-newsgroup-unreads
189 (append gnus-newsgroup-dormant gnus-newsgroup-marked))))
190 (gnus-soup-add-article nil)))
191 (gnus-summary-exit)))
193 (defun gnus-group-brew-soup (n)
194 "Make a soup packet from the current group."
196 (let ((groups (gnus-group-process-prefix n)))
198 (gnus-group-remove-mark (car groups))
199 (gnus-soup-group-brew (car groups))
200 (setq groups (cdr groups)))
203 (defun gnus-brew-soup (&optional level)
204 "Go through all groups on LEVEL or less and make a soup packet."
206 (let ((level (or level gnus-level-subscribed))
207 (newsrc (cdr gnus-newsrc-alist)))
209 (and (<= (nth 1 (car newsrc)) level)
210 (gnus-soup-group-brew (car (car newsrc))))
211 (setq newsrc (cdr newsrc)))
214 ;;; Internal Functions:
216 (defun gnus-soup-insert-idx (offset header)
217 ;; [number subject from date id references chars lines xref]
218 (goto-char (point-max))
220 (format "%d\t%s\t%s\t%s\t%s\t%s\t%d\t%s\t%s\t\n"
222 (or (header-subject header) "(none)")
223 (or (header-from header) "(nobody)")
224 (or (header-date header) "")
225 (or (header-id header)
226 (concat "soup-dummy-id-"
228 (lambda (time) (int-to-string time))
229 (current-time) "-")))
230 (or (header-references header) "")
231 (or (header-chars header) 0)
232 (or (header-lines header) "0")
233 (or (header-xref header) ""))))
235 (defun gnus-soup-save ()
236 (gnus-soup-write-areas)
239 (while gnus-soup-buffers
240 (setq buf (car gnus-soup-buffers)
241 gnus-soup-buffers (cdr gnus-soup-buffers))
242 (if (not (buffer-name buf))
245 (and (buffer-modified-p) (save-buffer))
246 (kill-buffer (current-buffer)))))
247 (gnus-set-work-buffer)
248 (insert (format "(setq gnus-soup-last-prefix %d)\n"
249 gnus-soup-last-prefix))
250 (write-region (point-min) (point-max) gnus-soup-prefix-file nil 'nomesg)))
252 (defun gnus-soup-pack ()
253 (let* ((dir (file-name-nondirectory
255 (file-name-as-directory gnus-soup-directory))))
256 (top (file-name-directory
258 (file-name-as-directory gnus-soup-directory))))
259 (files (mapconcat (lambda (f) (concat dir "/" f))
260 '("AREAS" "*.MSG" "*.IDX" "INFO"
261 "LIST" "REPLIES" "COMMANDS" "ERRORS")
263 (packer (if (< (string-match "%s" gnus-soup-packer)
264 (string-match "%d" gnus-soup-packer))
265 (format gnus-soup-packer files
266 (string-to-int (gnus-soup-unique-prefix)))
267 (format gnus-soup-packer
268 (string-to-int (gnus-soup-unique-prefix)) files))))
269 (if (zerop (call-process "sh" nil nil nil "-c"
270 (concat "cd " top " ; " packer)))
271 (call-process "sh" nil nil nil "-c"
272 (concat "cd " top " ; rm " files))
273 (error "Couldn't pack packet."))))
275 (defun gnus-soup-parse-areas (file)
276 "Parse soup area file FILE.
277 The result is a of vectors, each containing one entry from the AREA file.
278 The vector contain five strings,
279 [prefix name encoding description number]
280 though the two last may be nil if they are missing."
283 (set-buffer (find-file-noselect file))
284 (buffer-disable-undo)
285 (goto-char (point-min))
288 (cons (vector (gnus-soup-field)
291 (and (eq (preceding-char) ?\t) (gnus-soup-field))
292 (and (eq (preceding-char) ?\t) (gnus-soup-field)))
294 (if (eq (preceding-char) ?\t)
295 (beginning-of-line 2))))
298 (defun gnus-soup-field ()
300 (buffer-substring (point) (progn (skip-chars-forward "^\t\n") (point)))
303 (defun gnus-soup-read-areas ()
305 (setq gnus-soup-areas
306 (gnus-soup-parse-areas (concat gnus-soup-directory "AREAS")))))
308 (defun gnus-soup-write-areas ()
310 (set-buffer (find-file-noselect (concat gnus-soup-directory "AREAS")))
312 (let ((areas gnus-soup-areas)
315 (setq area (car areas)
317 (insert (aref area 0) ?\t (aref area 1) ?\t (aref area 2) ?\n)))
318 (write-region (point-min) (point-max)
319 (concat gnus-soup-directory "AREAS"))
320 (set-buffer-modified-p nil)
321 (kill-buffer (current-buffer))))
323 (defun gnus-soup-area (group)
324 (gnus-soup-read-areas)
325 (let ((areas gnus-soup-areas)
328 (setq area (car areas)
330 (if (equal (aref area 1) group)
334 (vector (gnus-soup-unique-prefix)
337 gnus-soup-encoding-type
339 (if (gnus-member-of-valid 'mail group) ?m ?n)
341 gnus-soup-areas (cons result gnus-soup-areas)))
344 (defun gnus-soup-unique-prefix ()
345 (if gnus-soup-last-prefix
347 (if (file-exists-p gnus-soup-prefix-file)
349 (load-file gnus-soup-prefix-file)
351 (setq gnus-soup-last-prefix 0)))
352 (int-to-string (setq gnus-soup-last-prefix (1+ gnus-soup-last-prefix))))
356 ;;; gnus-soup.el ends here