1;;; nnsoup.el --- SOUP access for Gnus
2
3;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
4;;   2004, 2005, 2006, 2007 Free Software Foundation, Inc.
5
6;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
7;;	Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
8;; Keywords: news, mail
9
10;; This file is part of GNU Emacs.
11
12;; GNU Emacs is free software; you can redistribute it and/or modify
13;; it under the terms of the GNU General Public License as published by
14;; the Free Software Foundation; either version 2, or (at your option)
15;; any later version.
16
17;; GNU Emacs is distributed in the hope that it will be useful,
18;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
20;; GNU General Public License for more details.
21
22;; You should have received a copy of the GNU General Public License
23;; along with GNU Emacs; see the file COPYING.  If not, write to the
24;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
25;; Boston, MA 02110-1301, USA.
26
27;;; Commentary:
28
29;;; Code:
30
31(require 'nnheader)
32(require 'nnmail)
33(require 'gnus-soup)
34(require 'gnus-msg)
35(require 'nnoo)
36(eval-when-compile (require 'cl))
37
38(nnoo-declare nnsoup)
39
40(defvoo nnsoup-directory (nnheader-concat gnus-home-directory "SOUP/")
41  "*SOUP packet directory.")
42
43(defvoo nnsoup-tmp-directory
44    (cond ((fboundp 'temp-directory) (temp-directory))
45	  ((boundp 'temporary-file-directory) temporary-file-directory)
46	  ("/tmp/"))
47  "*Where nnsoup will store temporary files.")
48
49(defvoo nnsoup-replies-directory (expand-file-name "replies/" nnsoup-directory)
50  "*Directory where outgoing packets will be composed.")
51
52(defvoo nnsoup-replies-format-type ?u  ;; u is USENET news format.
53  "*Format of the replies packages.")
54
55(defvoo nnsoup-replies-index-type ?n
56  "*Index type of the replies packages.")
57
58(defvoo nnsoup-active-file (expand-file-name "active" nnsoup-directory)
59  "Active file.")
60
61(defvoo nnsoup-packer (concat "tar cf - %s | gzip > "
62			      (expand-file-name gnus-home-directory)
63			      "Soupin%d.tgz")
64  "Format string command for packing a SOUP packet.
65The SOUP files will be inserted where the %s is in the string.
66This string MUST contain both %s and %d.  The file number will be
67inserted where %d appears.")
68
69(defvoo nnsoup-unpacker "gunzip -c %s | tar xvf -"
70  "*Format string command for unpacking a SOUP packet.
71The SOUP packet file name will be inserted at the %s.")
72
73(defvoo nnsoup-packet-directory gnus-home-directory
74  "*Where nnsoup will look for incoming packets.")
75
76(defvoo nnsoup-packet-regexp "Soupout"
77  "*Regular expression matching SOUP packets in `nnsoup-packet-directory'.")
78
79(defvoo nnsoup-always-save t
80  "If non-nil commit the reply buffer on each message send.
81This is necessary if using message mode outside Gnus with nnsoup as a
82backend for the messages.")
83
84
85
86(defconst nnsoup-version "nnsoup 0.0"
87  "nnsoup version.")
88
89(defvoo nnsoup-status-string "")
90(defvoo nnsoup-group-alist nil)
91(defvoo nnsoup-current-prefix 0)
92(defvoo nnsoup-replies-list nil)
93(defvoo nnsoup-buffers nil)
94(defvoo nnsoup-current-group nil)
95(defvoo nnsoup-group-alist-touched nil)
96(defvoo nnsoup-article-alist nil)
97
98
99;;; Interface functions.
100
101(nnoo-define-basics nnsoup)
102
103(deffoo nnsoup-retrieve-headers (sequence &optional group server fetch-old)
104  (nnsoup-possibly-change-group group)
105  (save-excursion
106    (set-buffer nntp-server-buffer)
107    (erase-buffer)
108    (let ((areas (cddr (assoc nnsoup-current-group nnsoup-group-alist)))
109	  (articles sequence)
110	  (use-nov t)
111	  useful-areas this-area-seq msg-buf)
112      (if (stringp (car sequence))
113	  ;; We don't support fetching by Message-ID.
114	  'headers
115	;; We go through all the areas and find which files the
116	;; articles in SEQUENCE come from.
117	(while (and areas sequence)
118	  ;; Peel off areas that are below sequence.
119	  (while (and areas (< (cdar (car areas)) (car sequence)))
120	    (setq areas (cdr areas)))
121	  (when areas
122	    ;; This is a useful area.
123	    (push (car areas) useful-areas)
124	    (setq this-area-seq nil)
125	    ;; We take note whether this MSG has a corresponding IDX
126	    ;; for later use.
127	    (when (or (= (gnus-soup-encoding-index
128			  (gnus-soup-area-encoding (nth 1 (car areas)))) ?n)
129		      (not (file-exists-p
130			    (nnsoup-file
131			     (gnus-soup-area-prefix (nth 1 (car areas)))))))
132	      (setq use-nov nil))
133	    ;; We assign the portion of `sequence' that is relevant to
134	    ;; this MSG packet to this packet.
135	    (while (and sequence (<= (car sequence) (cdar (car areas))))
136	      (push (car sequence) this-area-seq)
137	      (setq sequence (cdr sequence)))
138	    (setcar useful-areas (cons (nreverse this-area-seq)
139				       (car useful-areas)))))
140
141	;; We now have a list of article numbers and corresponding
142	;; areas.
143	(setq useful-areas (nreverse useful-areas))
144
145	;; Two different approaches depending on whether all the MSG
146	;; files have corresponding IDX files.  If they all do, we
147	;; simply return the relevant IDX files and let Gnus sort out
148	;; what lines are relevant.  If some of the IDX files are
149	;; missing, we must return HEADs for all the articles.
150	(if use-nov
151	    ;; We have IDX files for all areas.
152	    (progn
153	      (while useful-areas
154		(goto-char (point-max))
155		(let ((b (point))
156		      (number (car (nth 1 (car useful-areas))))
157		      (index-buffer (nnsoup-index-buffer
158				     (gnus-soup-area-prefix
159				      (nth 2 (car useful-areas))))))
160		  (when index-buffer
161		    (insert-buffer-substring index-buffer)
162		    (goto-char b)
163		    ;; We have to remove the index number entries and
164		    ;; insert article numbers instead.
165		    (while (looking-at "[0-9]+")
166		      (replace-match (int-to-string number) t t)
167		      (incf number)
168		      (forward-line 1))))
169		(setq useful-areas (cdr useful-areas)))
170	      'nov)
171	  ;; We insert HEADs.
172	  (while useful-areas
173	    (setq articles (caar useful-areas)
174		  useful-areas (cdr useful-areas))
175	    (while articles
176	      (when (setq msg-buf
177			  (nnsoup-narrow-to-article
178			   (car articles) (cdar useful-areas) 'head))
179		(goto-char (point-max))
180		(insert (format "221 %d Article retrieved.\n" (car articles)))
181		(insert-buffer-substring msg-buf)
182		(goto-char (point-max))
183		(insert ".\n"))
184	      (setq articles (cdr articles))))
185
186	  (nnheader-fold-continuation-lines)
187	  'headers)))))
188
189(deffoo nnsoup-open-server (server &optional defs)
190  (nnoo-change-server 'nnsoup server defs)
191  (when (not (file-exists-p nnsoup-directory))
192    (condition-case ()
193	(make-directory nnsoup-directory t)
194      (error t)))
195  (cond
196   ((not (file-exists-p nnsoup-directory))
197    (nnsoup-close-server)
198    (nnheader-report 'nnsoup "Couldn't create directory: %s" nnsoup-directory))
199   ((not (file-directory-p (file-truename nnsoup-directory)))
200    (nnsoup-close-server)
201    (nnheader-report 'nnsoup "Not a directory: %s" nnsoup-directory))
202   (t
203    (nnsoup-read-active-file)
204    (nnheader-report 'nnsoup "Opened server %s using directory %s"
205		     server nnsoup-directory)
206    t)))
207
208(deffoo nnsoup-request-close ()
209  (nnsoup-write-active-file)
210  (nnsoup-write-replies)
211  (gnus-soup-save-areas)
212  ;; Kill all nnsoup buffers.
213  (let (buffer)
214    (while nnsoup-buffers
215      (setq buffer (cdr (pop nnsoup-buffers)))
216      (and buffer
217	   (buffer-name buffer)
218	   (kill-buffer buffer))))
219  (setq nnsoup-group-alist nil
220	nnsoup-group-alist-touched nil
221	nnsoup-current-group nil
222	nnsoup-replies-list nil)
223  (nnoo-close-server 'nnoo)
224  t)
225
226(deffoo nnsoup-request-article (id &optional newsgroup server buffer)
227  (nnsoup-possibly-change-group newsgroup)
228  (let (buf)
229    (save-excursion
230      (set-buffer (or buffer nntp-server-buffer))
231      (erase-buffer)
232      (when (and (not (stringp id))
233		 (setq buf (nnsoup-narrow-to-article id)))
234	(insert-buffer-substring buf)
235	t))))
236
237(deffoo nnsoup-request-group (group &optional server dont-check)
238  (nnsoup-possibly-change-group group)
239  (if dont-check
240      t
241    (let ((active (cadr (assoc group nnsoup-group-alist))))
242      (if (not active)
243	  (nnheader-report 'nnsoup "No such group: %s" group)
244	(nnheader-insert
245	 "211 %d %d %d %s\n"
246	 (max (1+ (- (cdr active) (car active))) 0)
247	 (car active) (cdr active) group)))))
248
249(deffoo nnsoup-request-type (group &optional article)
250  (nnsoup-possibly-change-group group)
251  ;; Try to guess the type based on the first article in the group.
252  (when (not article)
253    (setq article
254	  (cdar (car (cddr (assoc group nnsoup-group-alist))))))
255  (if (not article)
256      'unknown
257    (let ((kind (gnus-soup-encoding-kind
258		 (gnus-soup-area-encoding
259		  (nth 1 (nnsoup-article-to-area
260			  article nnsoup-current-group))))))
261      (cond ((= kind ?m) 'mail)
262	    ((= kind ?n) 'news)
263	    (t 'unknown)))))
264
265(deffoo nnsoup-close-group (group &optional server)
266  ;; Kill all nnsoup buffers.
267  (let ((buffers nnsoup-buffers)
268	elem)
269    (while buffers
270      (when (equal (car (setq elem (pop buffers))) group)
271	(setq nnsoup-buffers (delq elem nnsoup-buffers))
272	(and (cdr elem) (buffer-name (cdr elem))
273	     (kill-buffer (cdr elem))))))
274  t)
275
276(deffoo nnsoup-request-list (&optional server)
277  (save-excursion
278    (set-buffer nntp-server-buffer)
279    (erase-buffer)
280    (unless nnsoup-group-alist
281      (nnsoup-read-active-file))
282    (let ((alist nnsoup-group-alist)
283	  (standard-output (current-buffer))
284	  entry)
285      (while (setq entry (pop alist))
286	(insert (car entry) " ")
287	(princ (cdadr entry))
288	(insert " ")
289	(princ (caadr entry))
290	(insert " y\n"))
291      t)))
292
293(deffoo nnsoup-request-scan (group &optional server)
294  (nnsoup-unpack-packets))
295
296(deffoo nnsoup-request-newgroups (date &optional server)
297  (nnsoup-request-list))
298
299(deffoo nnsoup-request-list-newsgroups (&optional server)
300  nil)
301
302(deffoo nnsoup-request-post (&optional server)
303  (nnsoup-store-reply "news")
304  t)
305
306(deffoo nnsoup-request-mail (&optional server)
307  (nnsoup-store-reply "mail")
308  t)
309
310(deffoo nnsoup-request-expire-articles (articles group &optional server force)
311  (nnsoup-possibly-change-group group)
312  (let* ((total-infolist (assoc group nnsoup-group-alist))
313	 (active (cadr total-infolist))
314	 (infolist (cddr total-infolist))
315	 info range-list mod-time prefix)
316    (while infolist
317      (setq info (pop infolist)
318	    range-list (gnus-uncompress-range (car info))
319	    prefix (gnus-soup-area-prefix (nth 1 info)))
320      (when;; All the articles in this file are marked for expiry.
321	  (and (or (setq mod-time (nth 5 (file-attributes
322					  (nnsoup-file prefix))))
323		   (setq mod-time (nth 5 (file-attributes
324					  (nnsoup-file prefix t)))))
325	       (gnus-sublist-p articles range-list)
326	       ;; This file is old enough.
327	       (nnmail-expired-article-p group mod-time force))
328	;; Ok, we delete this file.
329	(when (ignore-errors
330		(nnheader-message
331		 5 "Deleting %s in group %s..." (nnsoup-file prefix)
332		 group)
333		(when (file-exists-p (nnsoup-file prefix))
334		  (delete-file (nnsoup-file prefix)))
335		(nnheader-message
336		 5 "Deleting %s in group %s..." (nnsoup-file prefix t)
337		 group)
338		(when (file-exists-p (nnsoup-file prefix t))
339		  (delete-file (nnsoup-file prefix t)))
340		t)
341	  (setcdr (cdr total-infolist) (delq info (cddr total-infolist)))
342	  (setq articles (gnus-sorted-difference articles range-list))))
343      (when (not mod-time)
344	(setcdr (cdr total-infolist) (delq info (cddr total-infolist)))))
345    (if (cddr total-infolist)
346	(setcar active (caaadr (cdr total-infolist)))
347      (setcar active (1+ (cdr active))))
348    (nnsoup-write-active-file t)
349    ;; Return the articles that weren't expired.
350    articles))
351
352
353;;; Internal functions
354
355(defun nnsoup-possibly-change-group (group &optional force)
356  (when (and group
357	     (not (equal nnsoup-current-group group)))
358    (setq nnsoup-article-alist nil)
359    (setq nnsoup-current-group group))
360  t)
361
362(defun nnsoup-read-active-file ()
363  (setq nnsoup-group-alist nil)
364  (when (file-exists-p nnsoup-active-file)
365    (ignore-errors
366      (load nnsoup-active-file t t t))
367    ;; Be backwards compatible.
368    (when (and nnsoup-group-alist
369	       (not (atom (caadar nnsoup-group-alist))))
370      (let ((alist nnsoup-group-alist)
371	    entry e min max)
372	(while (setq e (cdr (setq entry (pop alist))))
373	  (setq min (caaar e))
374	  (while (cdr e)
375	    (setq e (cdr e)))
376	  (setq max (cdar (car e)))
377	  (setcdr entry (cons (cons min max) (cdr entry)))))
378      (setq nnsoup-group-alist-touched t))
379    nnsoup-group-alist))
380
381(defun nnsoup-write-active-file (&optional force)
382  (when (and nnsoup-group-alist
383	     (or force
384		 nnsoup-group-alist-touched))
385    (setq nnsoup-group-alist-touched nil)
386    (with-temp-file nnsoup-active-file
387      (gnus-prin1 `(setq nnsoup-group-alist ',nnsoup-group-alist))
388      (insert "\n")
389      (gnus-prin1 `(setq nnsoup-current-prefix ,nnsoup-current-prefix))
390      (insert "\n"))))
391
392(defun nnsoup-next-prefix ()
393  "Return the next free prefix."
394  (let (prefix)
395    (while (or (file-exists-p
396		(nnsoup-file (setq prefix (int-to-string
397					   nnsoup-current-prefix))))
398	       (file-exists-p (nnsoup-file prefix t)))
399      (incf nnsoup-current-prefix))
400    (incf nnsoup-current-prefix)
401    prefix))
402
403(defun nnsoup-file-name (dir file)
404  "Return the full name of FILE (in any case) in DIR."
405  (let* ((case-fold-search t)
406	 (files (directory-files dir t))
407	 (regexp (concat (regexp-quote file) "$")))
408    (car (delq nil
409	       (mapcar
410		(lambda (file)
411		  (if (string-match regexp file)
412		      file
413		    nil))
414		files)))))
415
416(defun nnsoup-read-areas ()
417  (let ((areas-file (nnsoup-file-name nnsoup-tmp-directory "areas")))
418    (when areas-file
419      (save-excursion
420	(set-buffer nntp-server-buffer)
421	(let ((areas (gnus-soup-parse-areas areas-file))
422	      entry number area lnum cur-prefix file)
423	  ;; Go through all areas in the new AREAS file.
424	  (while (setq area (pop areas))
425	    ;; Change the name to the permanent name and move the files.
426	    (setq cur-prefix (nnsoup-next-prefix))
427	    (nnheader-message 5 "Incorporating file %s..." cur-prefix)
428	    (when (file-exists-p
429		   (setq file
430			 (expand-file-name
431			  (concat (gnus-soup-area-prefix area) ".IDX")
432			  nnsoup-tmp-directory)))
433	      (rename-file file (nnsoup-file cur-prefix)))
434	    (when (file-exists-p
435		   (setq file (expand-file-name
436			       (concat (gnus-soup-area-prefix area) ".MSG")
437			       nnsoup-tmp-directory)))
438	      (rename-file file (nnsoup-file cur-prefix t))
439	      (gnus-soup-set-area-prefix area cur-prefix)
440	      ;; Find the number of new articles in this area.
441	      (setq number (nnsoup-number-of-articles area))
442	      (if (not (setq entry (assoc (gnus-soup-area-name area)
443					  nnsoup-group-alist)))
444		  ;; If this is a new area (group), we just add this info to
445		  ;; the group alist.
446		  (push (list (gnus-soup-area-name area)
447			      (cons 1 number)
448			      (list (cons 1 number) area))
449			nnsoup-group-alist)
450		;; There are already articles in this group, so we add this
451		;; info to the end of the entry.
452		(nconc entry (list (list (cons (1+ (setq lnum (cdadr entry)))
453					       (+ lnum number))
454					 area)))
455		(setcdr (cadr entry) (+ lnum number))))))
456	(nnsoup-write-active-file t)
457	(delete-file areas-file)))))
458
459(defun nnsoup-number-of-articles (area)
460  (save-excursion
461    (cond
462     ;; If the number is in the area info, we just return it.
463     ((gnus-soup-area-number area)
464      (gnus-soup-area-number area))
465     ;; If there is an index file, we just count the lines.
466     ((/= (gnus-soup-encoding-index (gnus-soup-area-encoding area)) ?n)
467      (set-buffer (nnsoup-index-buffer (gnus-soup-area-prefix area)))
468      (count-lines (point-min) (point-max)))
469     ;; We do it the hard way - re-searching through the message
470     ;; buffer.
471     (t
472      (set-buffer (nnsoup-message-buffer (gnus-soup-area-prefix area)))
473      (unless (assoc (gnus-soup-area-prefix area) nnsoup-article-alist)
474	(nnsoup-dissect-buffer area))
475      (length (cdr (assoc (gnus-soup-area-prefix area)
476			  nnsoup-article-alist)))))))
477
478(defun nnsoup-dissect-buffer (area)
479  (let ((mbox-delim (concat "^" message-unix-mail-delimiter))
480	(format (gnus-soup-encoding-format (gnus-soup-area-encoding area)))
481	(i 0)
482	alist len)
483    (goto-char (point-min))
484    (cond
485     ;; rnews batch format
486     ((or (= format ?u)
487	  (= format ?n)) ;; Gnus back compatibility.
488      (while (looking-at "^#! *rnews \\(+[0-9]+\\) *$")
489	(forward-line 1)
490	(push (list
491	       (incf i) (point)
492	       (progn
493		 (forward-char (string-to-number (match-string 1)))
494		 (point)))
495	      alist)))
496     ;; Unix mbox format
497     ((= format ?m)
498      (while (looking-at mbox-delim)
499	(forward-line 1)
500	(push (list
501	       (incf i) (point)
502	       (progn
503		 (if (re-search-forward mbox-delim nil t)
504		     (beginning-of-line)
505		   (goto-char (point-max)))
506		 (point)))
507	      alist)))
508     ;; MMDF format
509     ((= format ?M)
510      (while (looking-at "\^A\^A\^A\^A\n")
511	(forward-line 1)
512	(push (list
513	       (incf i) (point)
514	       (progn
515		 (if (search-forward "\n\^A\^A\^A\^A\n" nil t)
516		     (beginning-of-line)
517		   (goto-char (point-max)))
518		 (point)))
519	      alist)))
520     ;; Binary format
521     ((or (= format ?B) (= format ?b))
522      (while (not (eobp))
523	(setq len (+ (* (char-after (point)) (expt 2.0 24))
524		     (* (char-after (+ (point) 1)) (expt 2 16))
525		     (* (char-after (+ (point) 2)) (expt 2 8))
526		     (char-after (+ (point) 3))))
527	(push (list
528	       (incf i) (+ (point) 4)
529	       (progn
530		 (forward-char (floor (+ len 4)))
531		 (point)))
532	      alist)))
533     (t
534      (error "Unknown format: %c" format)))
535    (push (cons (gnus-soup-area-prefix area) alist) nnsoup-article-alist)))
536
537(defun nnsoup-index-buffer (prefix &optional message)
538  (let* ((file (concat prefix (if message ".MSG" ".IDX")))
539	 (buffer-name (concat " *nnsoup " file "*")))
540    (or (get-buffer buffer-name)	; File already loaded.
541	(when (file-exists-p (expand-file-name file nnsoup-directory))
542	  (save-excursion		; Load the file.
543	    (set-buffer (get-buffer-create buffer-name))
544	    (buffer-disable-undo)
545	    (push (cons nnsoup-current-group (current-buffer)) nnsoup-buffers)
546	    (nnheader-insert-file-contents
547	     (expand-file-name file nnsoup-directory))
548	    (current-buffer))))))
549
550(defun nnsoup-file (prefix &optional message)
551  (expand-file-name
552   (concat prefix (if message ".MSG" ".IDX"))
553   nnsoup-directory))
554
555(defun nnsoup-message-buffer (prefix)
556  (nnsoup-index-buffer prefix 'msg))
557
558(defun nnsoup-unpack-packets ()
559  "Unpack all packets in `nnsoup-packet-directory'."
560  (let ((packets (directory-files
561		  nnsoup-packet-directory t nnsoup-packet-regexp))
562	packet)
563    (while (setq packet (pop packets))
564      (nnheader-message 5 "nnsoup: unpacking %s..." packet)
565      (if (not (gnus-soup-unpack-packet
566		nnsoup-tmp-directory nnsoup-unpacker packet))
567	  (nnheader-message 5 "Couldn't unpack %s" packet)
568	(delete-file packet)
569	(nnsoup-read-areas)
570	(nnheader-message 5 "Unpacking...done")))))
571
572(defun nnsoup-narrow-to-article (article &optional area head)
573  (let* ((area (or area (nnsoup-article-to-area article nnsoup-current-group)))
574	 (prefix (and area (gnus-soup-area-prefix (nth 1 area))))
575	 (msg-buf (and prefix (nnsoup-index-buffer prefix 'msg)))
576	 beg end)
577    (when area
578      (save-excursion
579	(cond
580	 ;; There is no MSG file.
581	 ((null msg-buf)
582	  nil)
583	 ;; We use the index file to find out where the article
584	 ;; begins and ends.
585	 ((and (= (gnus-soup-encoding-index
586		   (gnus-soup-area-encoding (nth 1 area)))
587		  ?c)
588	       (file-exists-p (nnsoup-file prefix)))
589	  (set-buffer (nnsoup-index-buffer prefix))
590	  (widen)
591	  (goto-char (point-min))
592	  (forward-line (- article (caar area)))
593	  (setq beg (read (current-buffer)))
594	  (forward-line 1)
595	  (if (looking-at "[0-9]+")
596	      (progn
597		(setq end (read (current-buffer)))
598		(set-buffer msg-buf)
599		(widen)
600		(let ((format (gnus-soup-encoding-format
601			       (gnus-soup-area-encoding (nth 1 area)))))
602		  (goto-char end)
603		  (when (or (= format ?u) (= format ?n) (= format ?m))
604		    (setq end (progn (forward-line -1) (point))))))
605	    (set-buffer msg-buf))
606	  (widen)
607	  (narrow-to-region beg (or end (point-max))))
608	 (t
609	  (set-buffer msg-buf)
610	  (widen)
611	  (unless (assoc (gnus-soup-area-prefix (nth 1 area))
612			 nnsoup-article-alist)
613	    (nnsoup-dissect-buffer (nth 1 area)))
614	  (let ((entry (assq article (cdr (assoc (gnus-soup-area-prefix
615						  (nth 1 area))
616						 nnsoup-article-alist)))))
617	    (when entry
618	      (narrow-to-region (cadr entry) (caddr entry))))))
619	(goto-char (point-min))
620	(if (not head)
621	    ()
622	  (narrow-to-region
623	   (point-min)
624	   (if (search-forward "\n\n" nil t)
625	       (1- (point))
626	     (point-max))))
627	msg-buf))))
628
629;;;###autoload
630(defun nnsoup-pack-replies ()
631  "Make an outbound package of SOUP replies."
632  (interactive)
633  (unless (file-exists-p nnsoup-replies-directory)
634    (nnheader-message 5 "No such directory: %s" nnsoup-replies-directory))
635  ;; Write all data buffers.
636  (gnus-soup-save-areas)
637  ;; Write the active file.
638  (nnsoup-write-active-file)
639  ;; Write the REPLIES file.
640  (nnsoup-write-replies)
641  ;; Check whether there is anything here.
642  (when (null (directory-files nnsoup-replies-directory nil "\\.MSG$"))
643    (error "No files to pack"))
644  ;; Pack all these files into a SOUP packet.
645  (gnus-soup-pack nnsoup-replies-directory nnsoup-packer))
646
647(defun nnsoup-write-replies ()
648  "Write the REPLIES file."
649  (when nnsoup-replies-list
650    (gnus-soup-write-replies nnsoup-replies-directory nnsoup-replies-list)
651    (setq nnsoup-replies-list nil)))
652
653(defun nnsoup-article-to-area (article group)
654  "Return the area that ARTICLE in GROUP is located in."
655  (let ((areas (cddr (assoc group nnsoup-group-alist))))
656    (while (and areas (< (cdar (car areas)) article))
657      (setq areas (cdr areas)))
658    (and areas (car areas))))
659
660(defvar nnsoup-old-functions
661  (list message-send-mail-real-function message-send-news-function))
662
663;;;###autoload
664(defun nnsoup-set-variables ()
665  "Use the SOUP methods for posting news and mailing mail."
666  (interactive)
667  (setq message-send-news-function 'nnsoup-request-post)
668  (setq message-send-mail-real-function 'nnsoup-request-mail))
669
670;;;###autoload
671(defun nnsoup-revert-variables ()
672  "Revert posting and mailing methods to the standard Emacs methods."
673  (interactive)
674  (setq message-send-mail-real-function (car nnsoup-old-functions))
675  (setq message-send-news-function (cadr nnsoup-old-functions)))
676
677(defun nnsoup-store-reply (kind)
678  ;; Mostly stolen from `message.el'.
679  (require 'mail-utils)
680  (let ((tembuf (generate-new-buffer " message temp"))
681	(case-fold-search nil)
682	delimline
683	(mailbuf (current-buffer)))
684    (unwind-protect
685	(save-excursion
686	  (save-restriction
687	    (message-narrow-to-headers)
688	    (if (equal kind "mail")
689		(message-generate-headers message-required-mail-headers)
690	      (message-generate-headers message-required-news-headers)))
691	  (set-buffer tembuf)
692	  (erase-buffer)
693	  (insert-buffer-substring mailbuf)
694	  ;; Remove some headers.
695	  (save-restriction
696	    (message-narrow-to-headers)
697	    ;; Remove some headers.
698	    (message-remove-header message-ignored-mail-headers t))
699	  (goto-char (point-max))
700	  ;; require one newline at the end.
701	  (or (= (preceding-char) ?\n)
702	      (insert ?\n))
703	  (let ((case-fold-search t))
704	    ;; Change header-delimiter to be what sendmail expects.
705	    (goto-char (point-min))
706	    (re-search-forward
707	     (concat "^" (regexp-quote mail-header-separator) "\n"))
708	    (replace-match "\n")
709	    (backward-char 1)
710	    (setq delimline (point-marker))
711	    (goto-char (1+ delimline))
712	    (let ((msg-buf
713		   (gnus-soup-store
714		    nnsoup-replies-directory
715		    (nnsoup-kind-to-prefix kind) nil nnsoup-replies-format-type
716		    nnsoup-replies-index-type))
717		  (num 0))
718	      (when (and msg-buf (bufferp msg-buf))
719		(save-excursion
720		  (set-buffer msg-buf)
721		  (goto-char (point-min))
722		  (while (re-search-forward "^#! *rnews" nil t)
723		    (incf num))
724		  (when nnsoup-always-save
725		    (save-buffer)))
726		(nnheader-message 5 "Stored %d messages" num)))
727	    (nnsoup-write-replies)
728	    (kill-buffer tembuf))))))
729
730(defun nnsoup-kind-to-prefix (kind)
731  (unless nnsoup-replies-list
732    (setq nnsoup-replies-list
733	  (gnus-soup-parse-replies
734	   (expand-file-name "REPLIES" nnsoup-replies-directory))))
735  (let ((replies nnsoup-replies-list))
736    (while (and replies
737		(not (string= kind (gnus-soup-reply-kind (car replies)))))
738      (setq replies (cdr replies)))
739    (if replies
740	(gnus-soup-reply-prefix (car replies))
741      (push (vector (gnus-soup-unique-prefix nnsoup-replies-directory)
742		    kind
743		    (format "%c%c%c"
744			    nnsoup-replies-format-type
745			    nnsoup-replies-index-type
746			    (if (string= kind "news")
747				?n ?m)))
748	    nnsoup-replies-list)
749      (gnus-soup-reply-prefix (car nnsoup-replies-list)))))
750
751(defun nnsoup-make-active ()
752  "(Re-)create the SOUP active file."
753  (interactive)
754  (let ((files (sort (directory-files nnsoup-directory t "IDX$")
755		     (lambda (f1 f2)
756		       (< (progn (string-match "/\\([0-9]+\\)\\." f1)
757				 (string-to-number (match-string 1 f1)))
758			  (progn (string-match "/\\([0-9]+\\)\\." f2)
759				 (string-to-number (match-string 1 f2)))))))
760	active group lines ident elem min)
761    (set-buffer (get-buffer-create " *nnsoup work*"))
762    (while files
763      (nnheader-message 5 "Doing %s..." (car files))
764      (erase-buffer)
765      (nnheader-insert-file-contents (car files))
766      (goto-char (point-min))
767      (if (not (re-search-forward "^[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t *\\(Xref: \\)? *[^ ]* \\([^ ]+\\):[0-9]" nil t))
768	  (setq group "unknown")
769	(setq group (match-string 2)))
770      (setq lines (count-lines (point-min) (point-max)))
771      (setq ident (progn (string-match
772			  "/\\([0-9]+\\)\\." (car files))
773			 (substring
774			  (car files) (match-beginning 1)
775			  (match-end 1))))
776      (if (not (setq elem (assoc group active)))
777	  (push (list group (cons 1 lines)
778		      (list (cons 1 lines)
779			    (vector ident group "ucm" "" lines)))
780		active)
781	(nconc elem
782	       (list
783		(list (cons (1+ (setq min (cdadr elem)))
784			    (+ min lines))
785		      (vector ident group "ucm" "" lines))))
786	(setcdr (cadr elem) (+ min lines)))
787      (setq files (cdr files)))
788    (nnheader-message 5 "")
789    (setq nnsoup-group-alist active)
790    (nnsoup-write-active-file t)))
791
792(defun nnsoup-delete-unreferenced-message-files ()
793  "Delete any *.MSG and *.IDX files that aren't known by nnsoup."
794  (interactive)
795  (let* ((known (apply 'nconc (mapcar
796			       (lambda (ga)
797				 (mapcar
798				  (lambda (area)
799				    (gnus-soup-area-prefix (cadr area)))
800				  (cddr ga)))
801			       nnsoup-group-alist)))
802	 (regexp "\\.MSG$\\|\\.IDX$")
803	 (files (directory-files nnsoup-directory nil regexp))
804	 non-files file)
805    ;; Find all files that aren't known by nnsoup.
806    (while (setq file (pop files))
807      (string-match regexp file)
808      (unless (member (substring file 0 (match-beginning 0)) known)
809	(push file non-files)))
810    ;; Sort and delete the files.
811    (setq non-files (sort non-files 'string<))
812    (map-y-or-n-p "Delete file %s? "
813		  (lambda (file) (delete-file
814				  (expand-file-name file nnsoup-directory)))
815		  non-files)))
816
817(provide 'nnsoup)
818
819;;; arch-tag: b0451389-5703-4450-9425-f66f6b38c828
820;;; nnsoup.el ends here
821