*** empty log message ***
[gnus] / lisp / nnkiboze.el
1 ;;; nnkiboze.el --- select virtual news access for Gnus
2 ;; Copyright (C) 1995 Free Software Foundation, Inc.
3
4 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
5 ;; Keywords: news
6
7 ;; This file is part of GNU Emacs.
8
9 ;; GNU Emacs is free software; you can redistribute it and/or modify
10 ;; it under the terms of the GNU General Public License as published by
11 ;; the Free Software Foundation; either version 2, or (at your option)
12 ;; any later version.
13
14 ;; GNU Emacs is distributed in the hope that it will be useful,
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
17 ;; GNU General Public License for more details.
18
19 ;; You should have received a copy of the GNU General Public License
20 ;; along with GNU Emacs; see the file COPYING.  If not, write to
21 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
22
23 ;;; Commentary:
24
25 ;; The other access methods (nntp, nnspool, etc) are general news
26 ;; access methods. This module relies on Gnus and can not be used
27 ;; separately.
28
29 ;;; Code:
30
31 (require 'nntp)
32 (require 'nnheader)
33 (require 'gnus)
34 (require 'gnus-score)
35
36 (defvar nnkiboze-directory 
37   (expand-file-name (or gnus-article-save-directory "~/News/"))
38   "nnkiboze will put its files in this directory.")
39
40 \f
41
42 (defconst nnkiboze-version "nnkiboze 1.0"
43   "Version numbers of this version of nnkiboze.")
44
45 (defvar nnkiboze-current-group nil)
46 (defvar nnkiboze-current-score-group "")
47 (defvar nnkiboze-status-string "")
48
49 \f
50
51 ;;; Interface functions.
52
53 (defun nnkiboze-retrieve-headers (articles &optional group server)
54   (nnkiboze-possibly-change-newsgroups group)
55   (if gnus-nov-is-evil
56       nil
57     (if (stringp (car articles))
58         'headers
59       (let ((first (car articles))
60             (last (progn (while (cdr articles) (setq articles (cdr articles)))
61                          (car articles)))
62             (nov (nnkiboze-nov-file-name)))
63         (if (file-exists-p nov)
64             (save-excursion
65               (set-buffer nntp-server-buffer)
66               (erase-buffer)
67               (insert-file-contents nov)
68               (goto-char (point-min))
69               (while (and (not (eobp)) (< first (read (current-buffer))))
70                 (forward-line 1))
71               (beginning-of-line)
72               (if (not (eobp)) (delete-region 1 (point)))
73               (while (and (not (eobp)) (>= last (read (current-buffer))))
74                 (forward-line 1))
75               (beginning-of-line)
76               (if (not (eobp)) (delete-region (point) (point-max)))
77               'nov))))))
78
79 (defun nnkiboze-open-server (newsgroups &optional something)
80   "Open a virtual newsgroup that contains NEWSGROUPS."
81   (gnus-make-directory nnkiboze-directory)
82   (nnheader-init-server-buffer))
83
84 (defun nnkiboze-close-server (&rest dum)
85   "Close news server."
86   t)
87
88 (defalias 'nnkiboze-request-quit (symbol-function 'nnkiboze-close-server))
89
90 (defun nnkiboze-server-opened (&optional server)
91   "Return server process status, T or NIL.
92 If the stream is opened, return T, otherwise return NIL."
93   (and nntp-server-buffer
94        (get-buffer nntp-server-buffer)))
95
96 (defun nnkiboze-status-message (&optional server)
97   "Return server status response as string."
98   nnkiboze-status-string)
99
100 (defun nnkiboze-request-article (article &optional newsgroup server buffer)
101   "Select article by message number."
102   (nnkiboze-possibly-change-newsgroups newsgroup)
103   (if (not (numberp article))
104       ;; This is a real cludge. It might not work at times, but it
105       ;; does no harm I think. The only alternative is to offer no
106       ;; article fetching by message-id at all.
107       (nntp-request-article article newsgroup gnus-nntp-server buffer)
108     (let* ((header (gnus-get-header-by-number article))
109            (xref (mail-header-xref header))
110            igroup iarticle)
111       (or xref (error "nnkiboze: No xref"))
112       (or (string-match " \\([^ ]+\\):\\([0-9]+\\)" xref)
113           (error "nnkiboze: Malformed xref"))
114       (setq igroup (substring xref (match-beginning 1) (match-end 1)))
115       (setq iarticle (string-to-int 
116                       (substring xref (match-beginning 2) (match-end 2))))
117       (and (gnus-request-group igroup t)
118            (gnus-request-article iarticle igroup buffer)))))
119
120 (defun nnkiboze-request-group (group &optional server dont-check)
121   "Make GROUP the current newsgroup."
122   (nnkiboze-possibly-change-newsgroups group)
123   (if dont-check
124       ()
125     (let ((nov-file (nnkiboze-nov-file-name))
126           beg end total)
127       (save-excursion
128         (set-buffer nntp-server-buffer)
129         (erase-buffer)
130         (if (not (file-exists-p nov-file))
131             (insert (format "211 0 0 0 %s\n" group))
132           (insert-file-contents nov-file)
133           (if (zerop (buffer-size))
134               (insert (format "211 0 0 0 %s\n" group))
135             (goto-char (point-min))
136             (and (looking-at "[0-9]+") (setq beg (read (current-buffer))))
137             (goto-char (point-max))
138             (and (re-search-backward "^[0-9]" nil t)
139                  (setq end (read (current-buffer))))
140             (setq total (count-lines (point-min) (point-max)))
141             (erase-buffer)
142             (insert (format "211 %d %d %d %s\n" total beg end group)))))))
143   t)
144
145 (defun nnkiboze-close-group (group &optional server)
146   (nnkiboze-possibly-change-newsgroups group)
147   ;; Remove NOV lines of articles that are marked as read.
148   (if (not (file-exists-p (nnkiboze-nov-file-name)))
149       ()
150     (save-excursion
151       (let ((unreads gnus-newsgroup-unreads)
152             (unselected gnus-newsgroup-unselected)
153             (version-control 'never))
154         (set-buffer (get-buffer-create "*nnkiboze work*"))
155         (buffer-disable-undo (current-buffer))
156         (erase-buffer)
157         (let ((cur (current-buffer))
158               article)
159           (insert-file-contents (nnkiboze-nov-file-name))
160           (goto-char (point-min))
161           (while (looking-at "[0-9]+")
162             (if (or (memq (setq article (read cur)) unreads)
163                     (memq article unselected))
164                 (forward-line 1)
165               (delete-region (progn (beginning-of-line) (point))
166                              (progn (forward-line 1) (point)))))
167           (write-file (nnkiboze-nov-file-name))
168           (kill-buffer (current-buffer)))))
169     (setq nnkiboze-current-group nil)))
170
171 (defun nnkiboze-request-list (&optional server) 
172   (setq nnkiboze-status-string "nnkiboze: LIST is not implemented.")
173   nil)
174
175 (defun nnkiboze-request-newgroups (date &optional server)
176   "List new groups."
177   (setq nnkiboze-status-string "NEWGROUPS is not supported.")
178   nil)
179
180 (defun nnkiboze-request-list-newsgroups (&optional server)
181   (setq nnkiboze-status-string "nnkiboze: LIST NEWSGROUPS is not implemented.")
182   nil)
183
184 (defalias 'nnkiboze-request-post 'nntp-request-post)
185
186 (defalias 'nnkiboze-request-post-buffer 'nntp-request-post-buffer)
187
188 \f
189 ;;; Internal functions.
190
191 (defun nnkiboze-possibly-change-newsgroups (group)
192   (setq nnkiboze-current-group group))
193
194 (defun nnkiboze-prefixed-name (group)
195   (gnus-group-prefixed-name group '(nnkiboze "")))
196
197 ;;;###autoload
198 (defun nnkiboze-generate-groups ()
199   "Usage: emacs -batch -l nnkiboze -f nnkiboze-generate-groups
200 Finds out what articles are to be part of the nnkiboze groups."
201   (interactive)
202   (let ((nnmail-spool-file nil)
203         (gnus-use-dribble-file nil)
204         (gnus-read-active-file t)
205         (gnus-expert-user t))
206     (gnus))
207   (let* ((gnus-newsrc-alist (gnus-copy-sequence gnus-newsrc-alist))
208          (newsrc gnus-newsrc-alist))
209     (while newsrc
210       (if (string-match "nnkiboze" (car (car newsrc)))
211           (nnkiboze-generate-group (car (car newsrc))))
212       (setq newsrc (cdr newsrc)))))
213
214 (defun nnkiboze-score-file (group)
215   (list (expand-file-name
216          (concat gnus-kill-files-directory nnkiboze-current-score-group 
217                  "." gnus-score-file-suffix))))
218
219 (defun nnkiboze-generate-group (group) 
220   (let* ((info (nth 2 (gnus-gethash group gnus-newsrc-hashtb)))
221          (newsrc-file (concat nnkiboze-directory group ".newsrc"))
222          (nov-file (concat nnkiboze-directory group ".nov"))
223          (regexp (nth 1 (nth 4 info)))
224          (gnus-expert-user t)
225          (gnus-large-newsgroup nil)
226          (version-control 'never)
227          (gnus-score-find-score-files-function 'nnkiboze-score-file)
228          gnus-select-group-hook gnus-summary-prepare-hook 
229          gnus-thread-sort-functions gnus-show-threads 
230          gnus-visual
231          method nnkiboze-newsrc nov-buffer gname newsrc active
232          ginfo lowest)
233     (setq nnkiboze-current-score-group group)
234     (or info (error "No such group: %s" group))
235     (and (file-exists-p newsrc-file) (load newsrc-file))
236     (save-excursion
237       (set-buffer (setq nov-buffer (find-file-noselect nov-file)))
238       (buffer-disable-undo (current-buffer)))
239     ;; Go through the active hashtb and add new all groups that match the 
240     ;; kiboze regexp.
241     (mapatoms
242      (lambda (group)
243        (if (and (string-match regexp (setq gname (symbol-name group))) ; Match
244                 (not (assoc gname nnkiboze-newsrc)) ; It isn't registered
245                 (numberp (car (symbol-value group))) ; It is active
246                 (not (string-match "^nnkiboze:" gname))) ; Exclude kibozes
247            (setq nnkiboze-newsrc 
248                  (cons (cons gname (1- (car (symbol-value group))))
249                        nnkiboze-newsrc))))
250      gnus-active-hashtb)
251     (setq newsrc nnkiboze-newsrc)
252     (while newsrc
253       (if (not (setq active (gnus-gethash 
254                              (car (car newsrc)) gnus-active-hashtb)))
255           (setq nnkiboze-newsrc (delq (car newsrc) nnkiboze-newsrc))
256         (switch-to-buffer gnus-group-buffer)
257         (gnus-group-jump-to-group (car (car newsrc)))
258         (if (and (setq ginfo (nth 2 (gnus-gethash (gnus-group-group-name) 
259                                                   gnus-newsrc-hashtb)))
260                  (nth 3 ginfo))
261             (setcar (nthcdr 3 ginfo) nil))
262         (if (not (and (or (not ginfo)
263                           (> (length (gnus-list-of-unread-articles 
264                                       (car ginfo))) 0))
265                       (progn
266                         (gnus-group-select-group nil)
267                         (eq major-mode 'gnus-summary-mode))))
268             ()
269           (setq lowest (cdr (car newsrc)))
270           (setq method (gnus-find-method-for-group gnus-newsgroup-name))
271           (and (eq method gnus-select-method) (setq method nil))
272           (while gnus-newsgroup-scored
273             (if (> (car (car gnus-newsgroup-scored)) lowest)
274                 (nnkiboze-enter-nov 
275                  nov-buffer
276                  (gnus-get-header-by-number (car (car gnus-newsgroup-scored)))
277                  (if method
278                      (gnus-group-prefixed-name gnus-newsgroup-name method)
279                    gnus-newsgroup-name)))
280             (setq gnus-newsgroup-scored (cdr gnus-newsgroup-scored)))
281           (gnus-summary-quit)))
282       (setcdr (car newsrc) (car active))
283       (setq newsrc (cdr newsrc)))
284     (set-buffer nov-buffer)
285     (save-buffer)
286     (kill-buffer (current-buffer))
287     (set-buffer (get-buffer-create "*nnkiboze work*"))
288     (buffer-disable-undo (current-buffer))
289     (erase-buffer)
290     (insert "(setq nnkiboze-newsrc '" (prin1-to-string nnkiboze-newsrc)
291             ")\n")
292     (write-file newsrc-file)
293     (kill-buffer (current-buffer))
294     (switch-to-buffer gnus-group-buffer)
295     (gnus-group-list-groups 5 nil)))
296     
297 (defun nnkiboze-enter-nov (buffer header group)
298   (save-excursion
299     (set-buffer buffer)
300     (goto-char (point-max))
301     (let ((xref (mail-header-xref header))
302           (prefix (gnus-group-real-prefix group))
303           (first t)
304           article)
305       (if (zerop (forward-line -1))
306           (progn
307             (setq article (1+ (read (current-buffer))))
308             (forward-line 1))
309         (setq article 1))
310       (insert (int-to-string article) "\t"
311               (or (mail-header-subject header) "") "\t"
312               (or (mail-header-from header) "") "\t"
313               (or (mail-header-date header) "") "\t"
314               (or (mail-header-id header) "") "\t"
315               (or (mail-header-references header) "") "\t"
316               (int-to-string (or (mail-header-chars header) 0)) "\t"
317               (int-to-string (or (mail-header-lines header) 0)) "\t")
318       (if (or (not xref) (equal "" xref))
319           (insert "Xref: " (system-name) " " group ":" 
320                   (int-to-string (mail-header-number header))
321                   "\t\n")
322         (insert (mail-header-xref header) "\t\n")
323         (search-backward "\t" nil t)
324         (search-backward "\t" nil t)
325         (while (re-search-forward 
326                 "[^ ]+:[0-9]+"
327                 (save-excursion (end-of-line) (point)) t)
328           (if first
329               ;; The first xref has to be the group this article
330               ;; really came for - this is the article nnkiboze
331               ;; will request when it is asked for the article.
332               (save-excursion
333                 (goto-char (match-beginning 0))
334                 (insert prefix group ":" 
335                         (int-to-string (mail-header-number header)) " ")
336                 (setq first nil)))
337           (save-excursion
338             (goto-char (match-beginning 0))
339             (insert prefix)))))))
340
341 (defun nnkiboze-nov-file-name ()
342   (concat nnkiboze-directory
343           (nnkiboze-prefixed-name nnkiboze-current-group) ".nov"))
344
345 (provide 'nnkiboze)
346
347 ;;; nnkiboze.el ends here