1;;; nnspool.el --- spool access for GNU Emacs
2
3;; Copyright (C) 1988, 1989, 1990, 1993, 1994, 1995, 1996, 1997, 1998,
4;;   2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc.
5
6;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
7;;	Lars Magne Ingebrigtsen <larsi@gnus.org>
8;; Keywords: news
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 'nntp)
33(require 'nnoo)
34(eval-when-compile (require 'cl))
35
36(nnoo-declare nnspool)
37
38(defvoo nnspool-inews-program news-inews-program
39  "Program to post news.
40This is most commonly `inews' or `injnews'.")
41
42(defvoo nnspool-inews-switches '("-h" "-S")
43  "Switches for nnspool-request-post to pass to `inews' for posting news.
44If you are using Cnews, you probably should set this variable to nil.")
45
46(defvoo nnspool-spool-directory
47    (file-name-as-directory (if (boundp 'news-directory)
48				(symbol-value 'news-directory)
49			      news-path))
50  "Local news spool directory.")
51
52(defvoo nnspool-nov-directory (concat nnspool-spool-directory "over.view/")
53  "Local news nov directory.")
54
55(defvoo nnspool-lib-dir
56    (if (file-exists-p "/usr/lib/news/active")
57	"/usr/lib/news/"
58      "/var/lib/news/")
59  "Where the local news library files are stored.")
60
61(defvoo nnspool-active-file (concat nnspool-lib-dir "active")
62  "Local news active file.")
63
64(defvoo nnspool-newsgroups-file (concat nnspool-lib-dir "newsgroups")
65  "Local news newsgroups file.")
66
67(defvoo nnspool-distributions-file (concat nnspool-lib-dir "distribs.pat")
68  "Local news distributions file.")
69
70(defvoo nnspool-history-file (concat nnspool-lib-dir "history")
71  "Local news history file.")
72
73(defvoo nnspool-active-times-file (concat nnspool-lib-dir "active.times")
74  "Local news active date file.")
75
76(defvoo nnspool-large-newsgroup 50
77  "The number of articles which indicates a large newsgroup.
78If the number of articles is greater than the value, verbose
79messages will be shown to indicate the current status.")
80
81(defvoo nnspool-nov-is-evil nil
82  "Non-nil means that nnspool will never return NOV lines instead of headers.")
83
84(defconst nnspool-sift-nov-with-sed nil
85  "If non-nil, use sed to get the relevant portion from the overview file.
86If nil, nnspool will load the entire file into a buffer and process it
87there.")
88
89(defvoo nnspool-rejected-article-hook nil
90  "*A hook that will be run when an article has been rejected by the server.")
91
92(defvoo nnspool-file-coding-system nnheader-file-coding-system
93  "Coding system for nnspool.")
94
95
96
97(defconst nnspool-version "nnspool 2.0"
98  "Version numbers of this version of NNSPOOL.")
99
100(defvoo nnspool-current-directory nil
101  "Current news group directory.")
102
103(defvoo nnspool-current-group nil)
104(defvoo nnspool-status-string "")
105
106
107;;; Interface functions.
108
109(nnoo-define-basics nnspool)
110
111(deffoo nnspool-retrieve-headers (articles &optional group server fetch-old)
112  "Retrieve the headers of ARTICLES."
113  (save-excursion
114    (set-buffer nntp-server-buffer)
115    (erase-buffer)
116    (when (nnspool-possibly-change-directory group)
117      (let* ((number (length articles))
118	     (count 0)
119	     (default-directory nnspool-current-directory)
120	     (do-message (and (numberp nnspool-large-newsgroup)
121			      (> number nnspool-large-newsgroup)))
122	     (nnheader-file-coding-system nnspool-file-coding-system)
123	     file beg article ag)
124	(if (and (numberp (car articles))
125		 (nnspool-retrieve-headers-with-nov articles fetch-old))
126	    ;; We successfully retrieved the NOV headers.
127	    'nov
128	  ;; No NOV headers here, so we do it the hard way.
129	  (while (setq article (pop articles))
130	    (if (stringp article)
131		;; This is a Message-ID.
132		(setq ag (nnspool-find-id article)
133		      file (and ag (nnspool-article-pathname
134				    (car ag) (cdr ag)))
135		      article (cdr ag))
136	      ;; This is an article in the current group.
137	      (setq file (int-to-string article)))
138	    ;; Insert the head of the article.
139	    (when (and file
140		       (file-exists-p file))
141	      (insert "221 ")
142	      (princ article (current-buffer))
143	      (insert " Article retrieved.\n")
144	      (setq beg (point))
145	      (inline (nnheader-insert-head file))
146	      (goto-char beg)
147	      (if (search-forward "\n\n" nil t)
148		  (progn
149		    (forward-char -1)
150		    (insert ".\n"))
151		(goto-char (point-max))
152		(if (bolp)
153		    (insert ".\n")
154		  (insert "\n.\n")))
155	      (delete-region (point) (point-max)))
156
157	    (and do-message
158		 (zerop (% (incf count) 20))
159		 (nnheader-message 5 "nnspool: Receiving headers... %d%%"
160				   (/ (* count 100) number))))
161
162	  (when do-message
163	    (nnheader-message 5 "nnspool: Receiving headers...done"))
164
165	  ;; Fold continuation lines.
166	  (nnheader-fold-continuation-lines)
167	  'headers)))))
168
169(deffoo nnspool-open-server (server &optional defs)
170  (nnoo-change-server 'nnspool server defs)
171  (cond
172   ((not (file-exists-p nnspool-spool-directory))
173    (nnspool-close-server)
174    (nnheader-report 'nnspool "Spool directory doesn't exist: %s"
175		     nnspool-spool-directory))
176   ((not (file-directory-p
177	  (directory-file-name
178	   (file-truename nnspool-spool-directory))))
179    (nnspool-close-server)
180    (nnheader-report 'nnspool "Not a directory: %s" nnspool-spool-directory))
181   ((not (file-exists-p nnspool-active-file))
182    (nnheader-report 'nnspool "The active file doesn't exist: %s"
183		     nnspool-active-file))
184   (t
185    (nnheader-report 'nnspool "Opened server %s using directory %s"
186		     server nnspool-spool-directory)
187    t)))
188
189(deffoo nnspool-request-article (id &optional group server buffer)
190  "Select article by message ID (or number)."
191  (nnspool-possibly-change-directory group)
192  (let ((nntp-server-buffer (or buffer nntp-server-buffer))
193	file ag)
194    (if (stringp id)
195	;; This is a Message-ID.
196	(when (setq ag (nnspool-find-id id))
197	  (setq file (nnspool-article-pathname (car ag) (cdr ag))))
198      (setq file (nnspool-article-pathname nnspool-current-group id)))
199    (and file
200	 (file-exists-p file)
201	 (not (file-directory-p file))
202	 (save-excursion (nnspool-find-file file))
203	 ;; We return the article number and group name.
204	 (if (numberp id)
205	     (cons nnspool-current-group id)
206	   ag))))
207
208(deffoo nnspool-request-body (id &optional group server)
209  "Select article body by message ID (or number)."
210  (nnspool-possibly-change-directory group)
211  (let ((res (nnspool-request-article id)))
212    (when res
213      (save-excursion
214	(set-buffer nntp-server-buffer)
215	(goto-char (point-min))
216	(when (search-forward "\n\n" nil t)
217	  (delete-region (point-min) (point)))
218	res))))
219
220(deffoo nnspool-request-head (id &optional group server)
221  "Select article head by message ID (or number)."
222  (nnspool-possibly-change-directory group)
223  (let ((res (nnspool-request-article id)))
224    (when res
225      (save-excursion
226	(set-buffer nntp-server-buffer)
227	(goto-char (point-min))
228	(when (search-forward "\n\n" nil t)
229	  (delete-region (1- (point)) (point-max)))
230	(nnheader-fold-continuation-lines)))
231    res))
232
233(deffoo nnspool-request-group (group &optional server dont-check)
234  "Select news GROUP."
235  (let ((pathname (nnspool-article-pathname group))
236	dir)
237    (if (not (file-directory-p pathname))
238	(nnheader-report
239	 'nnspool "Invalid group name (no such directory): %s" group)
240      (setq nnspool-current-directory pathname)
241      (nnheader-report 'nnspool "Selected group %s" group)
242      (if dont-check
243	  (progn
244	    (nnheader-report 'nnspool "Selected group %s" group)
245	    t)
246	;; Yes, completely empty spool directories *are* possible.
247	;; Fix by Sudish Joseph <joseph@cis.ohio-state.edu>
248	(when (setq dir (directory-files pathname nil "^[0-9]+$" t))
249	  (setq dir
250		(sort (mapcar (lambda (name) (string-to-number name)) dir) '<)))
251	(if dir
252	    (nnheader-insert
253	     "211 %d %d %d %s\n" (length dir) (car dir)
254	     (progn (while (cdr dir) (setq dir (cdr dir))) (car dir))
255	     group)
256	  (nnheader-report 'nnspool "Empty group %s" group)
257	  (nnheader-insert "211 0 0 0 %s\n" group))))))
258
259(deffoo nnspool-request-type (group &optional article)
260  'news)
261
262(deffoo nnspool-close-group (group &optional server)
263  t)
264
265(deffoo nnspool-request-list (&optional server)
266  "List active newsgroups."
267  (save-excursion
268    (or (nnspool-find-file nnspool-active-file)
269	(nnheader-report 'nnspool (nnheader-file-error nnspool-active-file)))))
270
271(deffoo nnspool-request-list-newsgroups (&optional server)
272  "List newsgroups (defined in NNTP2)."
273  (save-excursion
274    (or (nnspool-find-file nnspool-newsgroups-file)
275	(nnheader-report 'nnspool (nnheader-file-error
276				   nnspool-newsgroups-file)))))
277
278(deffoo nnspool-request-list-distributions (&optional server)
279  "List distributions (defined in NNTP2)."
280  (save-excursion
281    (or (nnspool-find-file nnspool-distributions-file)
282	(nnheader-report 'nnspool (nnheader-file-error
283				   nnspool-distributions-file)))))
284
285;; Suggested by Hallvard B Furuseth <h.b.furuseth@usit.uio.no>.
286(deffoo nnspool-request-newgroups (date &optional server)
287  "List groups created after DATE."
288  (if (nnspool-find-file nnspool-active-times-file)
289      (save-excursion
290	;; Find the last valid line.
291	(goto-char (point-max))
292	(while (and (not (looking-at
293			  "\\([^ ]+\\) +\\([0-9]+\\)[0-9][0-9][0-9] "))
294		    (zerop (forward-line -1))))
295	(let ((seconds (time-to-seconds (date-to-time date)))
296	      groups)
297	  ;; Go through lines and add the latest groups to a list.
298	  (while (and (looking-at "\\([^ ]+\\) +[0-9]+ ")
299		      (progn
300			;; We insert a .0 to make the list reader
301			;; interpret the number as a float.  It is far
302			;; too big to be stored in a lisp integer.
303			(goto-char (1- (match-end 0)))
304			(insert ".0")
305			(> (progn
306			     (goto-char (match-end 1))
307			     (read (current-buffer)))
308			   seconds))
309		      (push (buffer-substring
310			     (match-beginning 1) (match-end 1))
311			    groups)
312		      (zerop (forward-line -1))))
313	  (erase-buffer)
314	  (while groups
315	    (insert (car groups) " 0 0 y\n")
316	    (setq groups (cdr groups))))
317	t)
318    nil))
319
320(deffoo nnspool-request-post (&optional server)
321  "Post a new news in current buffer."
322  (save-excursion
323    (let* ((process-connection-type nil) ; t bugs out on Solaris
324	   (inews-buffer (generate-new-buffer " *nnspool post*"))
325	   (proc
326	    (condition-case err
327		(apply 'start-process "*nnspool inews*" inews-buffer
328		       nnspool-inews-program nnspool-inews-switches)
329	      (error
330	       (nnheader-report 'nnspool "inews error: %S" err)))))
331      (if (not proc)
332	  ;; The inews program failed.
333	  ()
334	(nnheader-report 'nnspool "")
335	(set-process-sentinel proc 'nnspool-inews-sentinel)
336	(mm-with-unibyte-current-buffer
337	  (process-send-region proc (point-min) (point-max)))
338	;; We slap a condition-case around this, because the process may
339	;; have exited already...
340	(ignore-errors
341	  (process-send-eof proc))
342	t))))
343
344
345
346;;; Internal functions.
347
348(defun nnspool-inews-sentinel (proc status)
349  (save-excursion
350    (set-buffer (process-buffer proc))
351    (goto-char (point-min))
352    (if (or (zerop (buffer-size))
353	    (search-forward "spooled" nil t))
354	(kill-buffer (current-buffer))
355      ;; Make status message by folding lines.
356      (while (re-search-forward "[ \t\n]+" nil t)
357	(replace-match " " t t))
358      (nnheader-report 'nnspool "%s" (buffer-string))
359      (nnheader-message 5 "nnspool: %s" nnspool-status-string)
360      (ding)
361      (run-hooks 'nnspool-rejected-article-hook))))
362
363(defun nnspool-retrieve-headers-with-nov (articles &optional fetch-old)
364  (if (or gnus-nov-is-evil nnspool-nov-is-evil)
365      nil
366    (let ((nov (nnheader-group-pathname
367		nnspool-current-group nnspool-nov-directory ".overview"))
368	  (arts articles)
369	  (nnheader-file-coding-system nnspool-file-coding-system)
370	  last)
371      (if (not (file-exists-p nov))
372	  ()
373	(save-excursion
374	  (set-buffer nntp-server-buffer)
375	  (erase-buffer)
376	  (if nnspool-sift-nov-with-sed
377	      (nnspool-sift-nov-with-sed articles nov)
378	    (nnheader-insert-file-contents nov)
379	    (if (and fetch-old
380		     (not (numberp fetch-old)))
381		t			; We want all the headers.
382	      (ignore-errors
383		;; Delete unwanted NOV lines.
384		(nnheader-nov-delete-outside-range
385		 (if fetch-old (max 1 (- (car articles) fetch-old))
386		   (car articles))
387		 (car (last articles)))
388		;; If the buffer is empty, this wasn't very successful.
389		(unless (zerop (buffer-size))
390		  ;; We check what the last article number was.
391		  ;; The NOV file may be out of sync with the articles
392		  ;; in the group.
393		  (forward-line -1)
394		  (setq last (read (current-buffer)))
395		  (if (= last (car articles))
396		      ;; Yup, it's all there.
397		      t
398		    ;; Perhaps not.  We try to find the missing articles.
399		    (while (and arts
400				(<= last (car arts)))
401		      (pop arts))
402		    ;; The articles in `arts' are missing from the buffer.
403		    (while arts
404		      (nnspool-insert-nov-head (pop arts)))
405		    t))))))))))
406
407(defun nnspool-insert-nov-head (article)
408  "Read the head of ARTICLE, convert to NOV headers, and insert."
409  (save-excursion
410    (let ((cur (current-buffer))
411	  buf)
412      (setq buf (nnheader-set-temp-buffer " *nnspool head*"))
413      (when (nnheader-insert-head
414	     (nnspool-article-pathname nnspool-current-group article))
415	(nnheader-insert-article-line article)
416	(let ((headers (nnheader-parse-head)))
417	  (set-buffer cur)
418	  (goto-char (point-max))
419	  (nnheader-insert-nov headers)))
420      (kill-buffer buf))))
421
422(defun nnspool-sift-nov-with-sed (articles file)
423  (let ((first (car articles))
424	(last (progn (while (cdr articles) (setq articles (cdr articles)))
425		     (car articles))))
426    (call-process "awk" nil t nil
427		  (format "BEGIN {firstmsg=%d; lastmsg=%d;}\n $1 >= firstmsg && $1 <= lastmsg {print;}"
428			  (1- first) (1+ last))
429		  file)))
430
431;; Fixed by fdc@cliwe.ping.de (Frank D. Cringle).
432;; Find out what group an article identified by a Message-ID is in.
433(defun nnspool-find-id (id)
434  (save-excursion
435    (set-buffer (get-buffer-create " *nnspool work*"))
436    (erase-buffer)
437    (ignore-errors
438      (call-process "grep" nil t nil (regexp-quote id) nnspool-history-file))
439    (goto-char (point-min))
440    (prog1
441	(when (looking-at "<[^>]+>[ \t]+[-0-9~]+[ \t]+\\([^ /\t\n]+\\)/\\([0-9]+\\)[ \t\n]")
442	  (cons (match-string 1) (string-to-number (match-string 2))))
443      (kill-buffer (current-buffer)))))
444
445(defun nnspool-find-file (file)
446  "Insert FILE in server buffer safely."
447  (set-buffer nntp-server-buffer)
448  (erase-buffer)
449  (condition-case ()
450      (let ((coding-system-for-read nnspool-file-coding-system))
451	(mm-insert-file-contents file)
452	t)
453    (file-error nil)))
454
455(defun nnspool-possibly-change-directory (group)
456  (if (not group)
457      t
458    (let ((pathname (nnspool-article-pathname group)))
459      (if (file-directory-p pathname)
460	  (setq nnspool-current-directory pathname
461		nnspool-current-group group)
462	(nnheader-report 'nnspool "No such newsgroup: %s" group)))))
463
464(defun nnspool-article-pathname (group &optional article)
465  "Find the file name for GROUP."
466  (nnheader-group-pathname group nnspool-spool-directory article))
467
468(provide 'nnspool)
469
470;;; arch-tag: bdac8d27-2934-4eee-bad0-49e6b90c0d05
471;;; nnspool.el ends here
472