Mercurial > hg > xemacs-beta

comparison lisp/gnus/gnus-soup.el @ 70:131b0175ea99 r20-0b30

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-0b30
author cvs
date Mon, 13 Aug 2007 09:02:59 +0200
parents e04119814345
children 0d2f883870bc
comparison
equal deleted inserted replaced
69:804d1389bcd6 70:131b0175ea99
1 ;;; gnus-soup.el --- SOUP packet writing support for Gnus 1 ;;; gnus-soup.el --- SOUP packet writing support for Gnus
2 ;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. 2 ;; Copyright (C) 1995,96 Free Software Foundation, Inc.
3 3
4 ;; Author: Per Abrahamsen <abraham@iesd.auc.dk> 4 ;; Author: Per Abrahamsen <abraham@iesd.auc.dk>
5 ;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 5 ;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
6 ;; Keywords: news, mail 6 ;; Keywords: news, mail
7 7
24 24
25 ;;; Commentary: 25 ;;; Commentary:
26 26
27 ;;; Code: 27 ;;; Code:
28 28
29 (require 'gnus-msg)
29 (require 'gnus) 30 (require 'gnus)
30 (require 'gnus-art) 31 (eval-when-compile (require 'cl))
31 (require 'message)
32 (require 'gnus-start)
33 (require 'gnus-range)
34 32
35 ;;; User Variables: 33 ;;; User Variables:
36 34
37 (defvar gnus-soup-directory (nnheader-concat gnus-home-directory "SoupBrew/") 35 (defvar gnus-soup-directory "~/SoupBrew/"
38 "*Directory containing an unpacked SOUP packet.") 36 "*Directory containing an unpacked SOUP packet.")
39 37
40 (defvar gnus-soup-replies-directory 38 (defvar gnus-soup-replies-directory (concat gnus-soup-directory "SoupReplies/")
41 (nnheader-concat gnus-soup-directory "SoupReplies/")
42 "*Directory where Gnus will do processing of replies.") 39 "*Directory where Gnus will do processing of replies.")
43 40
44 (defvar gnus-soup-prefix-file "gnus-prefix" 41 (defvar gnus-soup-prefix-file "gnus-prefix"
45 "*Name of the file where Gnus stores the last used prefix.") 42 "*Name of the file where Gnus stores the last used prefix.")
46 43
47 (defvar gnus-soup-packer "tar cf - %s | gzip > $HOME/Soupout%d.tgz" 44 (defvar gnus-soup-packer "tar cf - %s | gzip > $HOME/Soupout%d.tgz"
48 "Format string command for packing a SOUP packet. 45 "Format string command for packing a SOUP packet.
49 The SOUP files will be inserted where the %s is in the string. 46 The SOUP files will be inserted where the %s is in the string.
50 This string MUST contain both %s and %d. The file number will be 47 This string MUST contain both %s and %d. The file number will be
51 inserted where %d appears.") 48 inserted where %d appears.")
52 49
53 (defvar gnus-soup-unpacker "gunzip -c %s | tar xvf -" 50 (defvar gnus-soup-unpacker "gunzip -c %s | tar xvf -"
54 "*Format string command for unpacking a SOUP packet. 51 "*Format string command for unpacking a SOUP packet.
55 The SOUP packet file name will be inserted at the %s.") 52 The SOUP packet file name will be inserted at the %s.")
56 53
57 (defvar gnus-soup-packet-directory gnus-home-directory 54 (defvar gnus-soup-packet-directory "~/"
58 "*Where gnus-soup will look for REPLIES packets.") 55 "*Where gnus-soup will look for REPLIES packets.")
59 56
60 (defvar gnus-soup-packet-regexp "Soupin" 57 (defvar gnus-soup-packet-regexp "Soupin"
61 "*Regular expression matching SOUP REPLIES packets in `gnus-soup-packet-directory'.") 58 "*Regular expression matching SOUP REPLIES packets in `gnus-soup-packet-directory'.")
62 59
71 format.") 68 format.")
72 69
73 (defvar gnus-soup-index-type ?c 70 (defvar gnus-soup-index-type ?c
74 "*Soup index type. 71 "*Soup index type.
75 `n' means no index file and `c' means standard Cnews overview 72 `n' means no index file and `c' means standard Cnews overview
76 format.") 73 format.")
77 74
78 (defvar gnus-soup-areas nil) 75 (defvar gnus-soup-areas nil)
79 (defvar gnus-soup-last-prefix nil) 76 (defvar gnus-soup-last-prefix nil)
80 (defvar gnus-soup-prev-prefix nil) 77 (defvar gnus-soup-prev-prefix nil)
81 (defvar gnus-soup-buffers nil) 78 (defvar gnus-soup-buffers nil)
117 "Unpack and send all replies in the reply packet." 114 "Unpack and send all replies in the reply packet."
118 (interactive) 115 (interactive)
119 (let ((packets (directory-files 116 (let ((packets (directory-files
120 gnus-soup-packet-directory t gnus-soup-packet-regexp))) 117 gnus-soup-packet-directory t gnus-soup-packet-regexp)))
121 (while packets 118 (while packets
122 (when (gnus-soup-send-packet (car packets)) 119 (and (gnus-soup-send-packet (car packets))
123 (delete-file (car packets))) 120 (delete-file (car packets)))
124 (setq packets (cdr packets))))) 121 (setq packets (cdr packets)))))
125 122
126 (defun gnus-soup-add-article (n) 123 (defun gnus-soup-add-article (n)
127 "Add the current article to SOUP packet. 124 "Add the current article to SOUP packet.
128 If N is a positive number, add the N next articles. 125 If N is a positive number, add the N next articles.
142 ;; Find the header of the article. 139 ;; Find the header of the article.
143 (set-buffer gnus-summary-buffer) 140 (set-buffer gnus-summary-buffer)
144 (when (setq headers (gnus-summary-article-header (car articles))) 141 (when (setq headers (gnus-summary-article-header (car articles)))
145 ;; Put the article in a buffer. 142 ;; Put the article in a buffer.
146 (set-buffer tmp-buf) 143 (set-buffer tmp-buf)
147 (when (gnus-request-article-this-buffer 144 (when (gnus-request-article-this-buffer
148 (car articles) gnus-newsgroup-name) 145 (car articles) gnus-newsgroup-name)
149 (save-restriction 146 (save-restriction
150 (message-narrow-to-head) 147 (message-narrow-to-head)
151 (message-remove-header gnus-soup-ignored-headers t)) 148 (message-remove-header gnus-soup-ignored-headers t))
152 (gnus-soup-store gnus-soup-directory prefix headers 149 (gnus-soup-store gnus-soup-directory prefix headers
153 gnus-soup-encoding-type 150 gnus-soup-encoding-type
154 gnus-soup-index-type) 151 gnus-soup-index-type)
155 (gnus-soup-area-set-number 152 (gnus-soup-area-set-number
156 area (1+ (or (gnus-soup-area-number area) 0))))) 153 area (1+ (or (gnus-soup-area-number area) 0)))))
157 ;; Mark article as read. 154 ;; Mark article as read.
158 (set-buffer gnus-summary-buffer) 155 (set-buffer gnus-summary-buffer)
159 (gnus-summary-remove-process-mark (car articles)) 156 (gnus-summary-remove-process-mark (car articles))
160 (gnus-summary-mark-as-read (car articles) gnus-souped-mark) 157 (gnus-summary-mark-as-read (car articles) gnus-souped-mark)
161 (setq articles (cdr articles))) 158 (setq articles (cdr articles)))
162 (kill-buffer tmp-buf)) 159 (kill-buffer tmp-buf))
164 161
165 (defun gnus-soup-pack-packet () 162 (defun gnus-soup-pack-packet ()
166 "Make a SOUP packet from the SOUP areas." 163 "Make a SOUP packet from the SOUP areas."
167 (interactive) 164 (interactive)
168 (gnus-soup-read-areas) 165 (gnus-soup-read-areas)
169 (unless (file-exists-p gnus-soup-directory)
170 (message "No such directory: %s" gnus-soup-directory))
171 (when (null (directory-files gnus-soup-directory nil "\\.MSG$"))
172 (message "No files to pack."))
173 (gnus-soup-pack gnus-soup-directory gnus-soup-packer)) 166 (gnus-soup-pack gnus-soup-directory gnus-soup-packer))
174 167
175 (defun gnus-group-brew-soup (n) 168 (defun gnus-group-brew-soup (n)
176 "Make a soup packet from the current group. 169 "Make a soup packet from the current group.
177 Uses the process/prefix convention." 170 Uses the process/prefix convention."
187 "Go through all groups on LEVEL or less and make a soup packet." 180 "Go through all groups on LEVEL or less and make a soup packet."
188 (interactive "P") 181 (interactive "P")
189 (let ((level (or level gnus-level-subscribed)) 182 (let ((level (or level gnus-level-subscribed))
190 (newsrc (cdr gnus-newsrc-alist))) 183 (newsrc (cdr gnus-newsrc-alist)))
191 (while newsrc 184 (while newsrc
192 (when (<= (nth 1 (car newsrc)) level) 185 (and (<= (nth 1 (car newsrc)) level)
193 (gnus-soup-group-brew (caar newsrc) t)) 186 (gnus-soup-group-brew (caar newsrc) t))
194 (setq newsrc (cdr newsrc))) 187 (setq newsrc (cdr newsrc)))
195 (gnus-soup-save-areas))) 188 (gnus-soup-save-areas)))
196 189
197 ;;;###autoload 190 ;;;###autoload
198 (defun gnus-batch-brew-soup () 191 (defun gnus-batch-brew-soup ()
203 For instance, if you want to brew on all the nnml groups, as well as 196 For instance, if you want to brew on all the nnml groups, as well as
204 groups with \"emacs\" in the name, you could say something like: 197 groups with \"emacs\" in the name, you could say something like:
205 198
206 $ emacs -batch -f gnus-batch-brew-soup ^nnml \".*emacs.*\"" 199 $ emacs -batch -f gnus-batch-brew-soup ^nnml \".*emacs.*\""
207 (interactive) 200 (interactive)
208 nil) 201 )
209 202
210 ;;; Internal Functions: 203 ;;; Internal Functions:
211 204
212 ;; Store the current buffer. 205 ;; Store the current buffer.
213 (defun gnus-soup-store (directory prefix headers format index) 206 (defun gnus-soup-store (directory prefix headers format index)
214 ;; Create the directory, if needed. 207 ;; Create the directory, if needed.
215 (gnus-make-directory directory) 208 (or (file-directory-p directory)
216 (let* ((msg-buf (nnheader-find-file-noselect 209 (gnus-make-directory directory))
210 (let* ((msg-buf (find-file-noselect
217 (concat directory prefix ".MSG"))) 211 (concat directory prefix ".MSG")))
218 (idx-buf (if (= index ?n) 212 (idx-buf (if (= index ?n)
219 nil 213 nil
220 (nnheader-find-file-noselect 214 (find-file-noselect
221 (concat directory prefix ".IDX")))) 215 (concat directory prefix ".IDX"))))
222 (article-buf (current-buffer)) 216 (article-buf (current-buffer))
223 from head-line beg type) 217 from head-line beg type)
224 (setq gnus-soup-buffers (cons msg-buf (delq msg-buf gnus-soup-buffers))) 218 (setq gnus-soup-buffers (cons msg-buf (delq msg-buf gnus-soup-buffers)))
225 (buffer-disable-undo msg-buf) 219 (buffer-disable-undo msg-buf)
226 (when idx-buf 220 (and idx-buf
227 (push idx-buf gnus-soup-buffers) 221 (progn
228 (buffer-disable-undo idx-buf)) 222 (setq gnus-soup-buffers (cons idx-buf gnus-soup-buffers))
223 (buffer-disable-undo idx-buf)))
229 (save-excursion 224 (save-excursion
230 ;; Make sure the last char in the buffer is a newline. 225 ;; Make sure the last char in the buffer is a newline.
231 (goto-char (point-max)) 226 (goto-char (point-max))
232 (unless (= (current-column) 0) 227 (or (= (current-column) 0)
233 (insert "\n")) 228 (insert "\n"))
234 ;; Find the "from". 229 ;; Find the "from".
235 (goto-char (point-min)) 230 (goto-char (point-min))
236 (setq from 231 (setq from
237 (gnus-mail-strip-quoted-names 232 (gnus-mail-strip-quoted-names
238 (or (mail-fetch-field "from") 233 (or (mail-fetch-field "from")
239 (mail-fetch-field "really-from") 234 (mail-fetch-field "really-from")
240 (mail-fetch-field "sender")))) 235 (mail-fetch-field "sender"))))
241 (goto-char (point-min)) 236 (goto-char (point-min))
242 ;; Depending on what encoding is supposed to be used, we make 237 ;; Depending on what encoding is supposed to be used, we make
243 ;; a soup header. 238 ;; a soup header.
244 (setq head-line 239 (setq head-line
245 (cond 240 (cond
246 ((= gnus-soup-encoding-type ?n) 241 ((= gnus-soup-encoding-type ?n)
247 (format "#! rnews %d\n" (buffer-size))) 242 (format "#! rnews %d\n" (buffer-size)))
248 ((= gnus-soup-encoding-type ?m) 243 ((= gnus-soup-encoding-type ?m)
249 (while (search-forward "\nFrom " nil t) 244 (while (search-forward "\nFrom " nil t)
250 (replace-match "\n>From " t t)) 245 (replace-match "\n>From " t t))
277 (when (or (null entry) 272 (when (or (null entry)
278 (eq (car entry) t) 273 (eq (car entry) t)
279 (and (car entry) 274 (and (car entry)
280 (> (car entry) 0)) 275 (> (car entry) 0))
281 (and (not not-all) 276 (and (not not-all)
282 (gnus-range-length (cdr (assq 'tick (gnus-info-marks 277 (gnus-range-length (cdr (assq 'tick (gnus-info-marks
283 (nth 2 entry))))))) 278 (nth 2 entry)))))))
284 (when (gnus-summary-read-group group nil t) 279 (when (gnus-summary-read-group group nil t)
285 (setq gnus-newsgroup-processable 280 (setq gnus-newsgroup-processable
286 (reverse 281 (reverse
287 (if (not not-all) 282 (if (not not-all)
298 offset 293 offset
299 (or (mail-header-subject header) "(none)") 294 (or (mail-header-subject header) "(none)")
300 (or (mail-header-from header) "(nobody)") 295 (or (mail-header-from header) "(nobody)")
301 (or (mail-header-date header) "") 296 (or (mail-header-date header) "")
302 (or (mail-header-id header) 297 (or (mail-header-id header)
303 (concat "soup-dummy-id-" 298 (concat "soup-dummy-id-"
304 (mapconcat 299 (mapconcat
305 (lambda (time) (int-to-string time)) 300 (lambda (time) (int-to-string time))
306 (current-time) "-"))) 301 (current-time) "-")))
307 (or (mail-header-references header) "") 302 (or (mail-header-references header) "")
308 (or (mail-header-chars header) 0) 303 (or (mail-header-chars header) 0)
309 (or (mail-header-lines header) "0")))) 304 (or (mail-header-lines header) "0"))))
310 305
311 (defun gnus-soup-save-areas () 306 (defun gnus-soup-save-areas ()
312 (gnus-soup-write-areas) 307 (gnus-soup-write-areas)
313 (save-excursion 308 (save-excursion
316 (setq buf (car gnus-soup-buffers) 311 (setq buf (car gnus-soup-buffers)
317 gnus-soup-buffers (cdr gnus-soup-buffers)) 312 gnus-soup-buffers (cdr gnus-soup-buffers))
318 (if (not (buffer-name buf)) 313 (if (not (buffer-name buf))
319 () 314 ()
320 (set-buffer buf) 315 (set-buffer buf)
321 (when (buffer-modified-p) 316 (and (buffer-modified-p) (save-buffer))
322 (save-buffer))
323 (kill-buffer (current-buffer))))) 317 (kill-buffer (current-buffer)))))
324 (gnus-soup-write-prefixes))) 318 (gnus-soup-write-prefixes)))
325 319
326 (defun gnus-soup-write-prefixes () 320 (defun gnus-soup-write-prefixes ()
327 (let ((prefixes gnus-soup-last-prefix) 321 (let ((prefix gnus-soup-last-prefix))
328 prefix)
329 (save-excursion 322 (save-excursion
330 (gnus-set-work-buffer) 323 (while prefix
331 (while (setq prefix (pop prefixes)) 324 (gnus-set-work-buffer)
332 (erase-buffer) 325 (insert (format "(setq gnus-soup-prev-prefix %d)\n" (cdar prefix)))
333 (insert (format "(setq gnus-soup-prev-prefix %d)\n" (cdr prefix))) 326 (gnus-make-directory (caar prefix))
334 (gnus-write-buffer (concat (car prefix) gnus-soup-prefix-file)))))) 327 (write-region (point-min) (point-max)
328 (concat (caar prefix) gnus-soup-prefix-file)
329 nil 'nomesg)
330 (setq prefix (cdr prefix))))))
335 331
336 (defun gnus-soup-pack (dir packer) 332 (defun gnus-soup-pack (dir packer)
337 (let* ((files (mapconcat 'identity 333 (let* ((files (mapconcat 'identity
338 '("AREAS" "*.MSG" "*.IDX" "INFO" 334 '("AREAS" "*.MSG" "*.IDX" "INFO"
339 "LIST" "REPLIES" "COMMANDS" "ERRORS") 335 "LIST" "REPLIES" "COMMANDS" "ERRORS")
340 " ")) 336 " "))
341 (packer (if (< (string-match "%s" packer) 337 (packer (if (< (string-match "%s" packer)
342 (string-match "%d" packer)) 338 (string-match "%d" packer))
343 (format packer files 339 (format packer files
344 (string-to-int (gnus-soup-unique-prefix dir))) 340 (string-to-int (gnus-soup-unique-prefix dir)))
345 (format packer 341 (format packer
346 (string-to-int (gnus-soup-unique-prefix dir)) 342 (string-to-int (gnus-soup-unique-prefix dir))
347 files))) 343 files)))
348 (dir (expand-file-name dir))) 344 (dir (expand-file-name dir)))
349 (gnus-make-directory dir) 345 (or (file-directory-p dir)
346 (gnus-make-directory dir))
350 (setq gnus-soup-areas nil) 347 (setq gnus-soup-areas nil)
351 (gnus-message 4 "Packing %s..." packer) 348 (gnus-message 4 "Packing %s..." packer)
352 (if (zerop (call-process shell-file-name 349 (if (zerop (call-process shell-file-name
353 nil nil nil shell-command-switch 350 nil nil nil shell-command-switch
354 (concat "cd " dir " ; " packer))) 351 (concat "cd " dir " ; " packer)))
355 (progn 352 (progn
356 (call-process shell-file-name nil nil nil shell-command-switch 353 (call-process shell-file-name nil nil nil shell-command-switch
357 (concat "cd " dir " ; rm " files)) 354 (concat "cd " dir " ; rm " files))
358 (gnus-message 4 "Packing...done" packer)) 355 (gnus-message 4 "Packing...done" packer))
359 (error "Couldn't pack packet.")))) 356 (error "Couldn't pack packet."))))
360 357
361 (defun gnus-soup-parse-areas (file) 358 (defun gnus-soup-parse-areas (file)
362 "Parse soup area file FILE. 359 "Parse soup area file FILE.
363 The result is a of vectors, each containing one entry from the AREA file. 360 The result is a of vectors, each containing one entry from the AREA file.
364 The vector contain five strings, 361 The vector contain five strings,
365 [prefix name encoding description number] 362 [prefix name encoding description number]
366 though the two last may be nil if they are missing." 363 though the two last may be nil if they are missing."
367 (let (areas) 364 (let (areas)
368 (save-excursion 365 (save-excursion
369 (set-buffer (nnheader-find-file-noselect file 'force)) 366 (set-buffer (find-file-noselect file 'force))
370 (buffer-disable-undo (current-buffer)) 367 (buffer-disable-undo (current-buffer))
371 (goto-char (point-min)) 368 (goto-char (point-min))
372 (while (not (eobp)) 369 (while (not (eobp))
373 (push (vector (gnus-soup-field) 370 (setq areas
374 (gnus-soup-field) 371 (cons (vector (gnus-soup-field)
375 (gnus-soup-field) 372 (gnus-soup-field)
376 (and (eq (preceding-char) ?\t) 373 (gnus-soup-field)
377 (gnus-soup-field)) 374 (and (eq (preceding-char) ?\t)
378 (and (eq (preceding-char) ?\t) 375 (gnus-soup-field))
379 (string-to-int (gnus-soup-field)))) 376 (and (eq (preceding-char) ?\t)
380 areas) 377 (string-to-int (gnus-soup-field))))
381 (when (eq (preceding-char) ?\t) 378 areas))
382 (beginning-of-line 2))) 379 (if (eq (preceding-char) ?\t)
380 (beginning-of-line 2)))
383 (kill-buffer (current-buffer))) 381 (kill-buffer (current-buffer)))
384 areas)) 382 areas))
385 383
386 (defun gnus-soup-parse-replies (file) 384 (defun gnus-soup-parse-replies (file)
387 "Parse soup REPLIES file FILE. 385 "Parse soup REPLIES file FILE.
388 The result is a of vectors, each containing one entry from the REPLIES 386 The result is a of vectors, each containing one entry from the REPLIES
389 file. The vector contain three strings, [prefix name encoding]." 387 file. The vector contain three strings, [prefix name encoding]."
390 (let (replies) 388 (let (replies)
391 (save-excursion 389 (save-excursion
392 (set-buffer (nnheader-find-file-noselect file)) 390 (set-buffer (find-file-noselect file))
393 (buffer-disable-undo (current-buffer)) 391 (buffer-disable-undo (current-buffer))
394 (goto-char (point-min)) 392 (goto-char (point-min))
395 (while (not (eobp)) 393 (while (not (eobp))
396 (push (vector (gnus-soup-field) (gnus-soup-field) 394 (setq replies
397 (gnus-soup-field)) 395 (cons (vector (gnus-soup-field) (gnus-soup-field)
398 replies) 396 (gnus-soup-field))
399 (when (eq (preceding-char) ?\t) 397 replies))
400 (beginning-of-line 2))) 398 (if (eq (preceding-char) ?\t)
399 (beginning-of-line 2)))
401 (kill-buffer (current-buffer))) 400 (kill-buffer (current-buffer)))
402 replies)) 401 replies))
403 402
404 (defun gnus-soup-field () 403 (defun gnus-soup-field ()
405 (prog1 404 (prog1
418 (nnheader-temp-write (concat gnus-soup-directory "AREAS") 417 (nnheader-temp-write (concat gnus-soup-directory "AREAS")
419 (let ((areas gnus-soup-areas) 418 (let ((areas gnus-soup-areas)
420 area) 419 area)
421 (while (setq area (pop areas)) 420 (while (setq area (pop areas))
422 (insert 421 (insert
423 (format 422 (format
424 "%s\t%s\t%s%s\n" 423 "%s\t%s\t%s%s\n"
425 (gnus-soup-area-prefix area) 424 (gnus-soup-area-prefix area)
426 (gnus-soup-area-name area) 425 (gnus-soup-area-name area)
427 (gnus-soup-area-encoding area) 426 (gnus-soup-area-encoding area)
428 (if (or (gnus-soup-area-description area) 427 (if (or (gnus-soup-area-description area)
429 (gnus-soup-area-number area)) 428 (gnus-soup-area-number area))
430 (concat "\t" (or (gnus-soup-area-description 429 (concat "\t" (or (gnus-soup-area-description
431 area) "") 430 area) "")
432 (if (gnus-soup-area-number area) 431 (if (gnus-soup-area-number area)
433 (concat "\t" (int-to-string 432 (concat "\t" (int-to-string
434 (gnus-soup-area-number area))) 433 (gnus-soup-area-number area)))
435 "")) "")))))))) 434 "")) ""))))))))
436 435
437 (defun gnus-soup-write-replies (dir areas) 436 (defun gnus-soup-write-replies (dir areas)
438 "Write a REPLIES file in DIR containing AREAS." 437 "Write a REPLIES file in DIR containing AREAS."
439 (nnheader-temp-write (concat dir "REPLIES") 438 (nnheader-temp-write (concat dir "REPLIES")
440 (let (area) 439 (let (area)
441 (while (setq area (pop areas)) 440 (while (setq area (pop areas))
442 (insert (format "%s\t%s\t%s\n" 441 (insert (format "%s\t%s\t%s\n"
443 (gnus-soup-reply-prefix area) 442 (gnus-soup-reply-prefix area)
444 (gnus-soup-reply-kind area) 443 (gnus-soup-reply-kind area)
445 (gnus-soup-reply-encoding area))))))) 444 (gnus-soup-reply-encoding area)))))))
446 445
447 (defun gnus-soup-area (group) 446 (defun gnus-soup-area (group)
448 (gnus-soup-read-areas) 447 (gnus-soup-read-areas)
449 (let ((areas gnus-soup-areas) 448 (let ((areas gnus-soup-areas)
450 (real-group (gnus-group-real-name group)) 449 (real-group (gnus-group-real-name group))
451 area result) 450 area result)
452 (while areas 451 (while areas
453 (setq area (car areas) 452 (setq area (car areas)
454 areas (cdr areas)) 453 areas (cdr areas))
455 (when (equal (gnus-soup-area-name area) real-group) 454 (if (equal (gnus-soup-area-name area) real-group)
456 (setq result area))) 455 (setq result area)))
457 (unless result 456 (or result
458 (setq result 457 (setq result
459 (vector (gnus-soup-unique-prefix) 458 (vector (gnus-soup-unique-prefix)
460 real-group 459 real-group
461 (format "%c%c%c" 460 (format "%c%c%c"
462 gnus-soup-encoding-type 461 gnus-soup-encoding-type
463 gnus-soup-index-type 462 gnus-soup-index-type
464 (if (gnus-member-of-valid 'mail group) ?m ?n)) 463 (if (gnus-member-of-valid 'mail group) ?m ?n))
465 nil nil) 464 nil nil)
466 gnus-soup-areas (cons result gnus-soup-areas))) 465 gnus-soup-areas (cons result gnus-soup-areas)))
467 result)) 466 result))
468 467
469 (defun gnus-soup-unique-prefix (&optional dir) 468 (defun gnus-soup-unique-prefix (&optional dir)
470 (let* ((dir (file-name-as-directory (or dir gnus-soup-directory))) 469 (let* ((dir (file-name-as-directory (or dir gnus-soup-directory)))
471 (entry (assoc dir gnus-soup-last-prefix)) 470 (entry (assoc dir gnus-soup-last-prefix))
472 gnus-soup-prev-prefix) 471 gnus-soup-prev-prefix)
473 (if entry 472 (if entry
474 () 473 ()
475 (when (file-exists-p (concat dir gnus-soup-prefix-file)) 474 (and (file-exists-p (concat dir gnus-soup-prefix-file))
476 (ignore-errors 475 (condition-case nil
477 (load (concat dir gnus-soup-prefix-file) nil t t))) 476 (load (concat dir gnus-soup-prefix-file) nil t t)
478 (push (setq entry (cons dir (or gnus-soup-prev-prefix 0))) 477 (error nil)))
479 gnus-soup-last-prefix)) 478 (setq gnus-soup-last-prefix
479 (cons (setq entry (cons dir (or gnus-soup-prev-prefix 0)))
480 gnus-soup-last-prefix)))
480 (setcdr entry (1+ (cdr entry))) 481 (setcdr entry (1+ (cdr entry)))
481 (gnus-soup-write-prefixes) 482 (gnus-soup-write-prefixes)
482 (int-to-string (cdr entry)))) 483 (int-to-string (cdr entry))))
483 484
484 (defun gnus-soup-unpack-packet (dir unpacker packet) 485 (defun gnus-soup-unpack-packet (dir unpacker packet)
487 (gnus-make-directory dir) 488 (gnus-make-directory dir)
488 (gnus-message 4 "Unpacking: %s" (format unpacker packet)) 489 (gnus-message 4 "Unpacking: %s" (format unpacker packet))
489 (prog1 490 (prog1
490 (zerop (call-process 491 (zerop (call-process
491 shell-file-name nil nil nil shell-command-switch 492 shell-file-name nil nil nil shell-command-switch
492 (format "cd %s ; %s" (expand-file-name dir) 493 (format "cd %s ; %s" (expand-file-name dir)
493 (format unpacker packet)))) 494 (format unpacker packet))))
494 (gnus-message 4 "Unpacking...done"))) 495 (gnus-message 4 "Unpacking...done")))
495 496
496 (defun gnus-soup-send-packet (packet) 497 (defun gnus-soup-send-packet (packet)
497 (gnus-soup-unpack-packet 498 (gnus-soup-unpack-packet
498 gnus-soup-replies-directory gnus-soup-unpacker packet) 499 gnus-soup-replies-directory gnus-soup-unpacker packet)
499 (let ((replies (gnus-soup-parse-replies 500 (let ((replies (gnus-soup-parse-replies
500 (concat gnus-soup-replies-directory "REPLIES")))) 501 (concat gnus-soup-replies-directory "REPLIES"))))
501 (save-excursion 502 (save-excursion
502 (while replies 503 (while replies
503 (let* ((msg-file (concat gnus-soup-replies-directory 504 (let* ((msg-file (concat gnus-soup-replies-directory
504 (gnus-soup-reply-prefix (car replies)) 505 (gnus-soup-reply-prefix (car replies))
505 ".MSG")) 506 ".MSG"))
506 (msg-buf (and (file-exists-p msg-file) 507 (msg-buf (and (file-exists-p msg-file)
507 (nnheader-find-file-noselect msg-file))) 508 (find-file-noselect msg-file)))
508 (tmp-buf (get-buffer-create " *soup send*")) 509 (tmp-buf (get-buffer-create " *soup send*"))
509 beg end) 510 beg end)
510 (cond 511 (cond
511 ((/= (gnus-soup-encoding-format 512 ((/= (gnus-soup-encoding-format
512 (gnus-soup-reply-encoding (car replies))) 513 (gnus-soup-reply-encoding (car replies))) ?n)
513 ?n)
514 (error "Unsupported encoding")) 514 (error "Unsupported encoding"))
515 ((null msg-buf) 515 ((null msg-buf)
516 t) 516 t)
517 (t 517 (t
518 (buffer-disable-undo msg-buf) 518 (buffer-disable-undo msg-buf)
519 (buffer-disable-undo tmp-buf) 519 (buffer-disable-undo tmp-buf)
520 (set-buffer msg-buf) 520 (set-buffer msg-buf)
521 (goto-char (point-min)) 521 (goto-char (point-min))
522 (while (not (eobp)) 522 (while (not (eobp))
523 (unless (looking-at "#! *rnews +\\([0-9]+\\)") 523 (or (looking-at "#! *rnews +\\([0-9]+\\)")
524 (error "Bad header.")) 524 (error "Bad header."))
525 (forward-line 1) 525 (forward-line 1)
526 (setq beg (point) 526 (setq beg (point)
527 end (+ (point) (string-to-int 527 end (+ (point) (string-to-int
528 (buffer-substring 528 (buffer-substring
529 (match-beginning 1) (match-end 1))))) 529 (match-beginning 1) (match-end 1)))))
530 (switch-to-buffer tmp-buf) 530 (switch-to-buffer tmp-buf)
531 (erase-buffer) 531 (erase-buffer)
532 (insert-buffer-substring msg-buf beg end) 532 (insert-buffer-substring msg-buf beg end)
533 (goto-char (point-min)) 533 (goto-char (point-min))
534 (search-forward "\n\n") 534 (search-forward "\n\n")
535 (forward-char -1) 535 (forward-char -1)
536 (insert mail-header-separator) 536 (insert mail-header-separator)
537 (setq message-newsreader (setq message-mailer 537 (setq message-newsreader (setq message-mailer
538 (gnus-extended-version))) 538 (gnus-extended-version)))
539 (cond 539 (cond
540 ((string= (gnus-soup-reply-kind (car replies)) "news") 540 ((string= (gnus-soup-reply-kind (car replies)) "news")
541 (gnus-message 5 "Sending news message to %s..." 541 (gnus-message 5 "Sending news message to %s..."
542 (mail-fetch-field "newsgroups")) 542 (mail-fetch-field "newsgroups"))
543 (sit-for 1) 543 (sit-for 1)
544 (let ((message-syntax-checks 544 (funcall message-send-news-function))
545 'dont-check-for-anything-just-trust-me))
546 (funcall message-send-news-function)))
547 ((string= (gnus-soup-reply-kind (car replies)) "mail") 545 ((string= (gnus-soup-reply-kind (car replies)) "mail")
548 (gnus-message 5 "Sending mail to %s..." 546 (gnus-message 5 "Sending mail to %s..."
549 (mail-fetch-field "to")) 547 (mail-fetch-field "to"))
550 (sit-for 1) 548 (sit-for 1)
551 (message-send-mail)) 549 (message-send-mail))
552 (t 550 (t
553 (error "Unknown reply kind"))) 551 (error "Unknown reply kind")))
554 (set-buffer msg-buf) 552 (set-buffer msg-buf)
557 (kill-buffer msg-buf) 555 (kill-buffer msg-buf)
558 (kill-buffer tmp-buf) 556 (kill-buffer tmp-buf)
559 (gnus-message 4 "Sent packet")))) 557 (gnus-message 4 "Sent packet"))))
560 (setq replies (cdr replies))) 558 (setq replies (cdr replies)))
561 t))) 559 t)))
562 560
563 (provide 'gnus-soup) 561 (provide 'gnus-soup)
564 562
565 ;;; gnus-soup.el ends here 563 ;;; gnus-soup.el ends here