Mercurial > hg > xemacs-beta

comparison lisp/gnus/gnus-soup.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children 0293115a14e9
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;;; gnus-soup.el --- SOUP packet writing support for Gnus
2 ;; Copyright (C) 1995,96 Free Software Foundation, Inc.
3
4 ;; Author: Per Abrahamsen <abraham@iesd.auc.dk>
5 ;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
6 ;; Keywords: news, mail
7
8 ;; This file is part of GNU Emacs.
9
10 ;; GNU Emacs is free software; you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 2, or (at your option)
13 ;; any later version.
14
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
19
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs; see the file COPYING. If not, write to the
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23 ;; Boston, MA 02111-1307, USA.
24
25 ;;; Commentary:
26
27 ;;; Code:
28
29 (require 'gnus-msg)
30 (require 'gnus)
31 (eval-when-compile (require 'cl))
32
33 ;;; User Variables:
34
35 (defvar gnus-soup-directory "~/SoupBrew/"
36 "*Directory containing an unpacked SOUP packet.")
37
38 (defvar gnus-soup-replies-directory (concat gnus-soup-directory "SoupReplies/")
39 "*Directory where Gnus will do processing of replies.")
40
41 (defvar gnus-soup-prefix-file "gnus-prefix"
42 "*Name of the file where Gnus stores the last used prefix.")
43
44 (defvar gnus-soup-packer "tar cf - %s | gzip > $HOME/Soupout%d.tgz"
45 "Format string command for packing a SOUP packet.
46 The SOUP files will be inserted where the %s is in the string.
47 This string MUST contain both %s and %d. The file number will be
48 inserted where %d appears.")
49
50 (defvar gnus-soup-unpacker "gunzip -c %s | tar xvf -"
51 "*Format string command for unpacking a SOUP packet.
52 The SOUP packet file name will be inserted at the %s.")
53
54 (defvar gnus-soup-packet-directory "~/"
55 "*Where gnus-soup will look for REPLIES packets.")
56
57 (defvar gnus-soup-packet-regexp "Soupin"
58 "*Regular expression matching SOUP REPLIES packets in `gnus-soup-packet-directory'.")
59
60 (defvar gnus-soup-ignored-headers "^Xref:"
61 "*Regexp to match headers to be removed when brewing SOUP packets.")
62
63 ;;; Internal Variables:
64
65 (defvar gnus-soup-encoding-type ?n
66 "*Soup encoding type.
67 `n' is news format, `m' is Unix mbox format, and `M' is MMDF mailbox
68 format.")
69
70 (defvar gnus-soup-index-type ?c
71 "*Soup index type.
72 `n' means no index file and `c' means standard Cnews overview
73 format.")
74
75 (defvar gnus-soup-areas nil)
76 (defvar gnus-soup-last-prefix nil)
77 (defvar gnus-soup-prev-prefix nil)
78 (defvar gnus-soup-buffers nil)
79
80 ;;; Access macros:
81
82 (defmacro gnus-soup-area-prefix (area)
83 `(aref ,area 0))
84 (defmacro gnus-soup-set-area-prefix (area prefix)
85 `(aset ,area 0 ,prefix))
86 (defmacro gnus-soup-area-name (area)
87 `(aref ,area 1))
88 (defmacro gnus-soup-area-encoding (area)
89 `(aref ,area 2))
90 (defmacro gnus-soup-area-description (area)
91 `(aref ,area 3))
92 (defmacro gnus-soup-area-number (area)
93 `(aref ,area 4))
94 (defmacro gnus-soup-area-set-number (area value)
95 `(aset ,area 4 ,value))
96
97 (defmacro gnus-soup-encoding-format (encoding)
98 `(aref ,encoding 0))
99 (defmacro gnus-soup-encoding-index (encoding)
100 `(aref ,encoding 1))
101 (defmacro gnus-soup-encoding-kind (encoding)
102 `(aref ,encoding 2))
103
104 (defmacro gnus-soup-reply-prefix (reply)
105 `(aref ,reply 0))
106 (defmacro gnus-soup-reply-kind (reply)
107 `(aref ,reply 1))
108 (defmacro gnus-soup-reply-encoding (reply)
109 `(aref ,reply 2))
110
111 ;;; Commands:
112
113 (defun gnus-soup-send-replies ()
114 "Unpack and send all replies in the reply packet."
115 (interactive)
116 (let ((packets (directory-files
117 gnus-soup-packet-directory t gnus-soup-packet-regexp)))
118 (while packets
119 (and (gnus-soup-send-packet (car packets))
120 (delete-file (car packets)))
121 (setq packets (cdr packets)))))
122
123 (defun gnus-soup-add-article (n)
124 "Add the current article to SOUP packet.
125 If N is a positive number, add the N next articles.
126 If N is a negative number, add the N previous articles.
127 If N is nil and any articles have been marked with the process mark,
128 move those articles instead."
129 (interactive "P")
130 (gnus-set-global-variables)
131 (let* ((articles (gnus-summary-work-articles n))
132 (tmp-buf (get-buffer-create "*soup work*"))
133 (area (gnus-soup-area gnus-newsgroup-name))
134 (prefix (gnus-soup-area-prefix area))
135 headers)
136 (buffer-disable-undo tmp-buf)
137 (save-excursion
138 (while articles
139 ;; Find the header of the article.
140 (set-buffer gnus-summary-buffer)
141 (when (setq headers (gnus-summary-article-header (car articles)))
142 ;; Put the article in a buffer.
143 (set-buffer tmp-buf)
144 (when (gnus-request-article-this-buffer
145 (car articles) gnus-newsgroup-name)
146 (save-restriction
147 (message-narrow-to-head)
148 (message-remove-header gnus-soup-ignored-headers t))
149 (gnus-soup-store gnus-soup-directory prefix headers
150 gnus-soup-encoding-type
151 gnus-soup-index-type)
152 (gnus-soup-area-set-number
153 area (1+ (or (gnus-soup-area-number area) 0)))))
154 ;; Mark article as read.
155 (set-buffer gnus-summary-buffer)
156 (gnus-summary-remove-process-mark (car articles))
157 (gnus-summary-mark-as-read (car articles) gnus-souped-mark)
158 (setq articles (cdr articles)))
159 (kill-buffer tmp-buf))
160 (gnus-soup-save-areas)))
161
162 (defun gnus-soup-pack-packet ()
163 "Make a SOUP packet from the SOUP areas."
164 (interactive)
165 (gnus-soup-read-areas)
166 (gnus-soup-pack gnus-soup-directory gnus-soup-packer))
167
168 (defun gnus-group-brew-soup (n)
169 "Make a soup packet from the current group.
170 Uses the process/prefix convention."
171 (interactive "P")
172 (let ((groups (gnus-group-process-prefix n)))
173 (while groups
174 (gnus-group-remove-mark (car groups))
175 (gnus-soup-group-brew (car groups) t)
176 (setq groups (cdr groups)))
177 (gnus-soup-save-areas)))
178
179 (defun gnus-brew-soup (&optional level)
180 "Go through all groups on LEVEL or less and make a soup packet."
181 (interactive "P")
182 (let ((level (or level gnus-level-subscribed))
183 (newsrc (cdr gnus-newsrc-alist)))
184 (while newsrc
185 (and (<= (nth 1 (car newsrc)) level)
186 (gnus-soup-group-brew (caar newsrc) t))
187 (setq newsrc (cdr newsrc)))
188 (gnus-soup-save-areas)))
189
190 ;;;###autoload
191 (defun gnus-batch-brew-soup ()
192 "Brew a SOUP packet from groups mention on the command line.
193 Will use the remaining command line arguments as regular expressions
194 for matching on group names.
195
196 For instance, if you want to brew on all the nnml groups, as well as
197 groups with \"emacs\" in the name, you could say something like:
198
199 $ emacs -batch -f gnus-batch-brew-soup ^nnml \".*emacs.*\""
200 (interactive)
201 )
202
203 ;;; Internal Functions:
204
205 ;; Store the current buffer.
206 (defun gnus-soup-store (directory prefix headers format index)
207 ;; Create the directory, if needed.
208 (or (file-directory-p directory)
209 (gnus-make-directory directory))
210 (let* ((msg-buf (find-file-noselect
211 (concat directory prefix ".MSG")))
212 (idx-buf (if (= index ?n)
213 nil
214 (find-file-noselect
215 (concat directory prefix ".IDX"))))
216 (article-buf (current-buffer))
217 from head-line beg type)
218 (setq gnus-soup-buffers (cons msg-buf (delq msg-buf gnus-soup-buffers)))
219 (buffer-disable-undo msg-buf)
220 (and idx-buf
221 (progn
222 (setq gnus-soup-buffers (cons idx-buf gnus-soup-buffers))
223 (buffer-disable-undo idx-buf)))
224 (save-excursion
225 ;; Make sure the last char in the buffer is a newline.
226 (goto-char (point-max))
227 (or (= (current-column) 0)
228 (insert "\n"))
229 ;; Find the "from".
230 (goto-char (point-min))
231 (setq from
232 (gnus-mail-strip-quoted-names
233 (or (mail-fetch-field "from")
234 (mail-fetch-field "really-from")
235 (mail-fetch-field "sender"))))
236 (goto-char (point-min))
237 ;; Depending on what encoding is supposed to be used, we make
238 ;; a soup header.
239 (setq head-line
240 (cond
241 ((= gnus-soup-encoding-type ?n)
242 (format "#! rnews %d\n" (buffer-size)))
243 ((= gnus-soup-encoding-type ?m)
244 (while (search-forward "\nFrom " nil t)
245 (replace-match "\n>From " t t))
246 (concat "From " (or from "unknown")
247 " " (current-time-string) "\n"))
248 ((= gnus-soup-encoding-type ?M)
249 "\^a\^a\^a\^a\n")
250 (t (error "Unsupported type: %c" gnus-soup-encoding-type))))
251 ;; Insert the soup header and the article in the MSG buf.
252 (set-buffer msg-buf)
253 (goto-char (point-max))
254 (insert head-line)
255 (setq beg (point))
256 (insert-buffer-substring article-buf)
257 ;; Insert the index in the IDX buf.
258 (cond ((= index ?c)
259 (set-buffer idx-buf)
260 (gnus-soup-insert-idx beg headers))
261 ((/= index ?n)
262 (error "Unknown index type: %c" type)))
263 ;; Return the MSG buf.
264 msg-buf)))
265
266 (defun gnus-soup-group-brew (group &optional not-all)
267 "Enter GROUP and add all articles to a SOUP package.
268 If NOT-ALL, don't pack ticked articles."
269 (let ((gnus-expert-user t)
270 (gnus-large-newsgroup nil)
271 (entry (gnus-gethash group gnus-newsrc-hashtb)))
272 (when (or (null entry)
273 (eq (car entry) t)
274 (and (car entry)
275 (> (car entry) 0))
276 (and (not not-all)
277 (gnus-range-length (cdr (assq 'tick (gnus-info-marks
278 (nth 2 entry)))))))
279 (when (gnus-summary-read-group group nil t)
280 (setq gnus-newsgroup-processable
281 (reverse
282 (if (not not-all)
283 (append gnus-newsgroup-marked gnus-newsgroup-unreads)
284 gnus-newsgroup-unreads)))
285 (gnus-soup-add-article nil)
286 (gnus-summary-exit)))))
287
288 (defun gnus-soup-insert-idx (offset header)
289 ;; [number subject from date id references chars lines xref]
290 (goto-char (point-max))
291 (insert
292 (format "%d\t%s\t%s\t%s\t%s\t%s\t%d\t%s\t\t\n"
293 offset
294 (or (mail-header-subject header) "(none)")
295 (or (mail-header-from header) "(nobody)")
296 (or (mail-header-date header) "")
297 (or (mail-header-id header)
298 (concat "soup-dummy-id-"
299 (mapconcat
300 (lambda (time) (int-to-string time))
301 (current-time) "-")))
302 (or (mail-header-references header) "")
303 (or (mail-header-chars header) 0)
304 (or (mail-header-lines header) "0"))))
305
306 (defun gnus-soup-save-areas ()
307 (gnus-soup-write-areas)
308 (save-excursion
309 (let (buf)
310 (while gnus-soup-buffers
311 (setq buf (car gnus-soup-buffers)
312 gnus-soup-buffers (cdr gnus-soup-buffers))
313 (if (not (buffer-name buf))
314 ()
315 (set-buffer buf)
316 (and (buffer-modified-p) (save-buffer))
317 (kill-buffer (current-buffer)))))
318 (gnus-soup-write-prefixes)))
319
320 (defun gnus-soup-write-prefixes ()
321 (let ((prefix gnus-soup-last-prefix))
322 (save-excursion
323 (while prefix
324 (gnus-set-work-buffer)
325 (insert (format "(setq gnus-soup-prev-prefix %d)\n" (cdar prefix)))
326 (gnus-make-directory (caar prefix))
327 (write-region (point-min) (point-max)
328 (concat (caar prefix) gnus-soup-prefix-file)
329 nil 'nomesg)
330 (setq prefix (cdr prefix))))))
331
332 (defun gnus-soup-pack (dir packer)
333 (let* ((files (mapconcat 'identity
334 '("AREAS" "*.MSG" "*.IDX" "INFO"
335 "LIST" "REPLIES" "COMMANDS" "ERRORS")
336 " "))
337 (packer (if (< (string-match "%s" packer)
338 (string-match "%d" packer))
339 (format packer files
340 (string-to-int (gnus-soup-unique-prefix dir)))
341 (format packer
342 (string-to-int (gnus-soup-unique-prefix dir))
343 files)))
344 (dir (expand-file-name dir)))
345 (or (file-directory-p dir)
346 (gnus-make-directory dir))
347 (setq gnus-soup-areas nil)
348 (gnus-message 4 "Packing %s..." packer)
349 (if (zerop (call-process shell-file-name
350 nil nil nil shell-command-switch
351 (concat "cd " dir " ; " packer)))
352 (progn
353 (call-process shell-file-name nil nil nil shell-command-switch
354 (concat "cd " dir " ; rm " files))
355 (gnus-message 4 "Packing...done" packer))
356 (error "Couldn't pack packet."))))
357
358 (defun gnus-soup-parse-areas (file)
359 "Parse soup area file FILE.
360 The result is a of vectors, each containing one entry from the AREA file.
361 The vector contain five strings,
362 [prefix name encoding description number]
363 though the two last may be nil if they are missing."
364 (let (areas)
365 (save-excursion
366 (set-buffer (find-file-noselect file 'force))
367 (buffer-disable-undo (current-buffer))
368 (goto-char (point-min))
369 (while (not (eobp))
370 (setq areas
371 (cons (vector (gnus-soup-field)
372 (gnus-soup-field)
373 (gnus-soup-field)
374 (and (eq (preceding-char) ?\t)
375 (gnus-soup-field))
376 (and (eq (preceding-char) ?\t)
377 (string-to-int (gnus-soup-field))))
378 areas))
379 (if (eq (preceding-char) ?\t)
380 (beginning-of-line 2)))
381 (kill-buffer (current-buffer)))
382 areas))
383
384 (defun gnus-soup-parse-replies (file)
385 "Parse soup REPLIES file FILE.
386 The result is a of vectors, each containing one entry from the REPLIES
387 file. The vector contain three strings, [prefix name encoding]."
388 (let (replies)
389 (save-excursion
390 (set-buffer (find-file-noselect file))
391 (buffer-disable-undo (current-buffer))
392 (goto-char (point-min))
393 (while (not (eobp))
394 (setq replies
395 (cons (vector (gnus-soup-field) (gnus-soup-field)
396 (gnus-soup-field))
397 replies))
398 (if (eq (preceding-char) ?\t)
399 (beginning-of-line 2)))
400 (kill-buffer (current-buffer)))
401 replies))
402
403 (defun gnus-soup-field ()
404 (prog1
405 (buffer-substring (point) (progn (skip-chars-forward "^\t\n") (point)))
406 (forward-char 1)))
407
408 (defun gnus-soup-read-areas ()
409 (or gnus-soup-areas
410 (setq gnus-soup-areas
411 (gnus-soup-parse-areas (concat gnus-soup-directory "AREAS")))))
412
413 (defun gnus-soup-write-areas ()
414 "Write the AREAS file."
415 (interactive)
416 (when gnus-soup-areas
417 (nnheader-temp-write (concat gnus-soup-directory "AREAS")
418 (let ((areas gnus-soup-areas)
419 area)
420 (while (setq area (pop areas))
421 (insert
422 (format
423 "%s\t%s\t%s%s\n"
424 (gnus-soup-area-prefix area)
425 (gnus-soup-area-name area)
426 (gnus-soup-area-encoding area)
427 (if (or (gnus-soup-area-description area)
428 (gnus-soup-area-number area))
429 (concat "\t" (or (gnus-soup-area-description
430 area) "")
431 (if (gnus-soup-area-number area)
432 (concat "\t" (int-to-string
433 (gnus-soup-area-number area)))
434 "")) ""))))))))
435
436 (defun gnus-soup-write-replies (dir areas)
437 "Write a REPLIES file in DIR containing AREAS."
438 (nnheader-temp-write (concat dir "REPLIES")
439 (let (area)
440 (while (setq area (pop areas))
441 (insert (format "%s\t%s\t%s\n"
442 (gnus-soup-reply-prefix area)
443 (gnus-soup-reply-kind area)
444 (gnus-soup-reply-encoding area)))))))
445
446 (defun gnus-soup-area (group)
447 (gnus-soup-read-areas)
448 (let ((areas gnus-soup-areas)
449 (real-group (gnus-group-real-name group))
450 area result)
451 (while areas
452 (setq area (car areas)
453 areas (cdr areas))
454 (if (equal (gnus-soup-area-name area) real-group)
455 (setq result area)))
456 (or result
457 (setq result
458 (vector (gnus-soup-unique-prefix)
459 real-group
460 (format "%c%c%c"
461 gnus-soup-encoding-type
462 gnus-soup-index-type
463 (if (gnus-member-of-valid 'mail group) ?m ?n))
464 nil nil)
465 gnus-soup-areas (cons result gnus-soup-areas)))
466 result))
467
468 (defun gnus-soup-unique-prefix (&optional dir)
469 (let* ((dir (file-name-as-directory (or dir gnus-soup-directory)))
470 (entry (assoc dir gnus-soup-last-prefix))
471 gnus-soup-prev-prefix)
472 (if entry
473 ()
474 (and (file-exists-p (concat dir gnus-soup-prefix-file))
475 (condition-case nil
476 (load (concat dir gnus-soup-prefix-file) nil t t)
477 (error nil)))
478 (setq gnus-soup-last-prefix
479 (cons (setq entry (cons dir (or gnus-soup-prev-prefix 0)))
480 gnus-soup-last-prefix)))
481 (setcdr entry (1+ (cdr entry)))
482 (gnus-soup-write-prefixes)
483 (int-to-string (cdr entry))))
484
485 (defun gnus-soup-unpack-packet (dir unpacker packet)
486 "Unpack PACKET into DIR using UNPACKER.
487 Return whether the unpacking was successful."
488 (gnus-make-directory dir)
489 (gnus-message 4 "Unpacking: %s" (format unpacker packet))
490 (prog1
491 (zerop (call-process
492 shell-file-name nil nil nil shell-command-switch
493 (format "cd %s ; %s" (expand-file-name dir)
494 (format unpacker packet))))
495 (gnus-message 4 "Unpacking...done")))
496
497 (defun gnus-soup-send-packet (packet)
498 (gnus-soup-unpack-packet
499 gnus-soup-replies-directory gnus-soup-unpacker packet)
500 (let ((replies (gnus-soup-parse-replies
501 (concat gnus-soup-replies-directory "REPLIES"))))
502 (save-excursion
503 (while replies
504 (let* ((msg-file (concat gnus-soup-replies-directory
505 (gnus-soup-reply-prefix (car replies))
506 ".MSG"))
507 (msg-buf (and (file-exists-p msg-file)
508 (find-file-noselect msg-file)))
509 (tmp-buf (get-buffer-create " *soup send*"))
510 beg end)
511 (cond
512 ((/= (gnus-soup-encoding-format
513 (gnus-soup-reply-encoding (car replies))) ?n)
514 (error "Unsupported encoding"))
515 ((null msg-buf)
516 t)
517 (t
518 (buffer-disable-undo msg-buf)
519 (buffer-disable-undo tmp-buf)
520 (set-buffer msg-buf)
521 (goto-char (point-min))
522 (while (not (eobp))
523 (or (looking-at "#! *rnews +\\([0-9]+\\)")
524 (error "Bad header."))
525 (forward-line 1)
526 (setq beg (point)
527 end (+ (point) (string-to-int
528 (buffer-substring
529 (match-beginning 1) (match-end 1)))))
530 (switch-to-buffer tmp-buf)
531 (erase-buffer)
532 (insert-buffer-substring msg-buf beg end)
533 (goto-char (point-min))
534 (search-forward "\n\n")
535 (forward-char -1)
536 (insert mail-header-separator)
537 (setq message-newsreader (setq message-mailer
538 (gnus-extended-version)))
539 (cond
540 ((string= (gnus-soup-reply-kind (car replies)) "news")
541 (gnus-message 5 "Sending news message to %s..."
542 (mail-fetch-field "newsgroups"))
543 (sit-for 1)
544 (funcall message-send-news-function))
545 ((string= (gnus-soup-reply-kind (car replies)) "mail")
546 (gnus-message 5 "Sending mail to %s..."
547 (mail-fetch-field "to"))
548 (sit-for 1)
549 (message-send-mail))
550 (t
551 (error "Unknown reply kind")))
552 (set-buffer msg-buf)
553 (goto-char end))
554 (delete-file (buffer-file-name))
555 (kill-buffer msg-buf)
556 (kill-buffer tmp-buf)
557 (gnus-message 4 "Sent packet"))))
558 (setq replies (cdr replies)))
559 t)))
560
561 (provide 'gnus-soup)
562
563 ;;; gnus-soup.el ends here