1 ;;; nnvirtual.el --- virtual newsgroups access for Gnus
2 ;; Copyright (C) 1994,95,96 Free Software Foundation, Inc.
4 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
5 ;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
8 ;; This file is part of GNU Emacs.
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)
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.
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.
27 ;; The other access methods (nntp, nnspool, etc) are general news
28 ;; access methods. This module relies on Gnus and can not be used
36 (eval-when-compile (require 'cl))
38 (defvar nnvirtual-always-rescan nil
39 "*If non-nil, always scan groups for unread articles when entering a group.
40 If this variable is nil (which is the default) and you read articles
41 in a component group after the virtual group has been activated, the
42 read articles from the component group will show up when you enter the
47 (defconst nnvirtual-version "nnvirtual 1.0"
48 "Version number of this version of nnvirtual.")
50 (defvar nnvirtual-group-alist nil)
51 (defvar nnvirtual-current-group nil)
52 (defvar nnvirtual-component-groups nil)
53 (defvar nnvirtual-mapping nil)
55 (defvar nnvirtual-status-string "")
58 (autoload 'gnus-cache-articles-in-group "gnus-cache"))
62 ;;; Interface functions.
64 (defun nnvirtual-retrieve-headers (articles &optional newsgroup server fetch-old)
65 (when (nnvirtual-possibly-change-group newsgroup server)
67 (if (stringp (car articles))
69 (let ((vbuf (nnheader-set-temp-buffer
70 (get-buffer-create " *virtual headers*")))
71 (unfetched (mapcar (lambda (g) (list g))
72 nnvirtual-component-groups))
73 (system-name (system-name))
74 cgroup article result prefix)
76 (setq article (assq (pop articles) nnvirtual-mapping))
77 (when (and (setq cgroup (cadr article))
79 (gnus-find-method-for-group cgroup) t)
80 (gnus-request-group cgroup t))
81 (setq prefix (gnus-group-real-prefix cgroup))
82 (when (setq result (gnus-retrieve-headers
83 (list (caddr article)) cgroup nil))
84 (set-buffer nntp-server-buffer)
85 (if (zerop (buffer-size))
86 (nconc (assq cgroup unfetched) (list (caddr article)))
87 ;; If we got HEAD headers, we convert them into NOV
88 ;; headers. This is slow, inefficient and, come to think
89 ;; of it, downright evil. So sue me. I couldn't be
90 ;; bothered to write a header parse routine that could
91 ;; parse a mixed HEAD/NOV buffer.
92 (when (eq result 'headers)
93 (nnvirtual-convert-headers))
94 (goto-char (point-min))
97 (point) (progn (read nntp-server-buffer) (point)))
98 (princ (car article) (current-buffer))
101 "[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t")
102 (goto-char (match-end 0))
104 "\t" (save-excursion (end-of-line) (point)) t)
106 (while (= (char-after (1- (point))) ? )
112 (or (= (char-after (1- (point))) ?\t)
114 (insert "Xref: " system-name " " cgroup ":")
115 (princ (caddr article) (current-buffer))
117 (insert "Xref: " system-name " " cgroup ":")
118 (princ (caddr article) (current-buffer))
120 (if (not (string= "" prefix))
121 (while (re-search-forward
123 (save-excursion (end-of-line) (point)) t)
125 (goto-char (match-beginning 0))
128 (or (= (char-after (1- (point))) ?\t)
132 (goto-char (point-max))
133 (insert-buffer-substring nntp-server-buffer)))))
135 ;; In case some of the articles have expired or been
136 ;; cancelled, we have to mark them as read in the
139 (when (cdar unfetched)
140 (gnus-group-make-articles-read
141 (caar unfetched) (sort (cdar unfetched) '<)))
142 (setq unfetched (cdr unfetched)))
144 ;; The headers are ready for reading, so they are inserted into
145 ;; the nntp-server-buffer, which is where Gnus expects to find
149 (set-buffer nntp-server-buffer)
151 (insert-buffer-substring vbuf)
153 (kill-buffer vbuf)))))))
155 (defun nnvirtual-open-server (server &optional something)
156 (nnheader-init-server-buffer))
158 (defun nnvirtual-close-server (&rest dum)
161 (defun nnvirtual-request-close ()
162 (setq nnvirtual-current-group nil
163 nnvirtual-component-groups nil
164 nnvirtual-mapping nil
165 nnvirtual-group-alist nil)
168 (defun nnvirtual-server-opened (&optional server)
169 (and nntp-server-buffer
170 (get-buffer nntp-server-buffer)))
172 (defun nnvirtual-status-message (&optional server)
173 nnvirtual-status-string)
175 (defun nnvirtual-request-article (article &optional group server buffer)
176 (when (and (nnvirtual-possibly-change-group group server)
178 (let* ((amap (assq article nnvirtual-mapping))
179 (cgroup (cadr amap)))
182 (nnheader-report 'nnvirtual "No such article: %s" article))
183 ((not (gnus-check-group cgroup))
185 'nnvirtual "Can't open server where %s exists" cgroup))
186 ((not (gnus-request-group cgroup t))
187 (nnheader-report 'nnvirtual "Can't open component group %s" cgroup))
192 (gnus-request-article-this-buffer (caddr amap) cgroup))
193 (gnus-request-article (caddr amap) cgroup)))))))
195 (defun nnvirtual-request-group (group &optional server dont-check)
197 ((null (nnvirtual-possibly-change-group
199 (if nnvirtual-always-rescan nil (not dont-check))))
200 (setq nnvirtual-current-group nil)
201 (nnheader-report 'nnvirtual "No component groups in %s" group))
203 (let ((len (length nnvirtual-mapping)))
204 (nnheader-insert "211 %d 1 %d %s\n" len len group)))))
206 (defun nnvirtual-request-type (group &optional article)
207 (when (nnvirtual-possibly-change-group group nil)
210 (let ((mart (assq article nnvirtual-mapping)))
212 (gnus-request-type (cadr mart) (car mart)))))))
214 (defun nnvirtual-request-update-mark (group article mark)
215 (when (nnvirtual-possibly-change-group group nil)
216 (let* ((nart (assq article nnvirtual-mapping))
218 ;; The component group might be a virtual group.
219 (nmark (gnus-request-update-mark cgroup (caddr nart) mark)))
220 (when (and (= mark nmark)
221 (gnus-group-auto-expirable-p cgroup))
222 (setq mark gnus-expirable-mark))))
225 (defun nnvirtual-close-group (group &optional server)
226 (when (nnvirtual-possibly-change-group group server)
227 ;; Copy (un)read articles.
228 (nnvirtual-update-reads)
229 (setq nnvirtual-mapping nil
230 nnvirtual-current-group nil
231 nnvirtual-component-groups nil)
232 ;; We copy the marks from this group to the component
234 (nnvirtual-update-marked))
237 (defun nnvirtual-request-list (&optional server)
238 (nnheader-report 'nnvirtual "LIST is not implemented."))
240 (defun nnvirtual-request-newgroups (date &optional server)
241 (nnheader-report 'nnvirtual "NEWGROUPS is not supported."))
243 (defun nnvirtual-request-list-newsgroups (&optional server)
244 (nnheader-report 'nnvirtual "LIST NEWSGROUPS is not implemented."))
246 (defun nnvirtual-request-update-info (group info &optional server)
247 (when (nnvirtual-possibly-change-group group server)
248 (let ((map nnvirtual-mapping)
249 (marks (mapcar (lambda (m) (list (cdr m))) gnus-article-mark-lists))
251 ;; Go through the mapping.
253 (unless (nth 3 (setq m (pop map)))
255 (push (car m) reads))
257 (when (setq mr (nth 4 m))
259 (setcdr (setq op (assq (pop mr) marks)) (cons (car m) (cdr op))))))
260 ;; Compress the marks and the reads.
263 (setcdr (car mr) (gnus-compress-sequence (sort (cdr (pop mr)) '<))))
264 (setcar (cddr info) (gnus-compress-sequence (nreverse reads)))
265 ;; Remove empty marks lists.
266 (while (and marks (not (cdar marks)))
267 (setq marks (cdr marks)))
272 (setcdr mr (cddr mr))))
274 ;; Enter these new marks into the info of the group.
276 (setcar (nthcdr 3 info) marks)
277 ;; Add the marks lists to the end of the info.
279 (setcdr (nthcdr 2 info) (list marks))))
282 (defun nnvirtual-catchup-group (group &optional server all)
283 (nnvirtual-possibly-change-group group server)
284 (let ((gnus-group-marked nnvirtual-component-groups)
285 (gnus-expert-user t))
286 ;; Make sure all groups are activated.
289 (when (not (numberp (car (gnus-gethash g gnus-newsrc-hashtb))))
290 (gnus-activate-group g)))
291 nnvirtual-component-groups)
293 (set-buffer gnus-group-buffer)
294 (gnus-group-catchup-current nil all))))
296 (defun nnvirtual-find-group-art (group article)
297 "Return the real group and article for virtual GROUP and ARTICLE."
298 (nnvirtual-possibly-change-group group nil)
299 (let ((mart (assq article nnvirtual-mapping)))
301 (cons (cadr mart) (caddr mart)))))
304 ;;; Internal functions.
306 (defun nnvirtual-convert-headers ()
307 "Convert HEAD headers into NOV headers."
309 (set-buffer nntp-server-buffer)
310 (let* ((dependencies (make-vector 100 0))
311 (headers (gnus-get-newsgroup-headers dependencies))
314 (while (setq header (pop headers))
315 (insert (int-to-string (mail-header-number header)) "\t"
316 (or (mail-header-subject header) "") "\t"
317 (or (mail-header-from header) "") "\t"
318 (or (mail-header-date header) "") "\t"
319 (or (mail-header-id header) "") "\t"
320 (or (mail-header-references header) "") "\t"
321 (int-to-string (or (mail-header-chars header) 0)) "\t"
322 (int-to-string (or (mail-header-lines header) 0)) "\t"
323 (if (mail-header-xref header)
324 (concat "Xref: " (mail-header-xref header) "\t")
327 (defun nnvirtual-possibly-change-group (group regexp &optional check)
329 (when (or (not (equal group nnvirtual-current-group))
331 (setq inf (assoc group nnvirtual-group-alist))
332 (when nnvirtual-current-group
333 ;; Push the old group variables onto the alist.
334 (setq nnvirtual-group-alist
335 (cons (list nnvirtual-current-group
336 nnvirtual-component-groups
338 (delq inf nnvirtual-group-alist))))
340 ;; We nix out the variables.
341 (setq nnvirtual-current-group nil
342 nnvirtual-component-groups nil
343 nnvirtual-mapping nil
344 nnvirtual-group-alist
345 (delq (assoc group nnvirtual-group-alist)
346 nnvirtual-group-alist))
347 (setq nnvirtual-current-group nil
348 nnvirtual-component-groups nil
349 nnvirtual-mapping nil)
350 ;; Try to find the variables in the assoc.
351 (when (and inf (equal (nth 3 inf) regexp))
352 (setq nnvirtual-current-group (car inf)
353 nnvirtual-component-groups (nth 1 inf)
354 nnvirtual-mapping (nth 2 inf))))
356 (unless nnvirtual-component-groups
357 (setq nnvirtual-mapping nil)
358 (setq nnvirtual-current-group group)
359 ;; Go through the newsrc alist and find all component groups.
360 (let ((newsrc (cdr gnus-newsrc-alist))
361 (virt-group (gnus-group-prefixed-name
362 nnvirtual-current-group '(nnvirtual ""))))
363 (while (setq group (car (pop newsrc)))
364 (and (string-match regexp group) ; Match
365 ;; Virtual groups shouldn't include itself.
366 (not (string= group virt-group))
367 ;; Add this group to the list of component groups.
368 (setq nnvirtual-component-groups
370 (delete group nnvirtual-component-groups))))))
371 (if (not nnvirtual-component-groups)
372 (nnheader-report 'nnvirtual "No component groups: %s" group)
373 (nnvirtual-create-mapping)))))
374 nnvirtual-component-groups)
376 (defun nnvirtual-update-marked ()
377 "Copy marks from the virtual group to the component groups."
378 (let ((mark-lists gnus-article-mark-lists)
379 (marks (gnus-info-marks (gnus-get-info
381 nnvirtual-current-group))))
382 type list mart cgroups)
383 (while (setq type (cdr (pop mark-lists)))
384 (setq list (gnus-uncompress-range (cdr (assq type marks))))
386 (mapcar (lambda (g) (list g)) nnvirtual-component-groups))
388 (nconc (assoc (cadr (setq mart (assq (pop list) nnvirtual-mapping)))
390 (list (caddr mart))))
392 (gnus-add-marked-articles
393 (caar cgroups) type (cdar cgroups) nil t)
394 (gnus-group-update-group (car (pop cgroups)) t)))))
396 (defun nnvirtual-update-reads ()
397 "Copy (un)reads from the current group to the component groups."
398 (let ((groups (mapcar (lambda (g) (list g)) nnvirtual-component-groups))
399 (articles (gnus-list-of-unread-articles
400 (concat "nnvirtual:" nnvirtual-current-group)))
403 (setq m (assq (pop articles) nnvirtual-mapping))
404 (nconc (assoc (nth 1 m) groups) (list (nth 2 m))))
406 (gnus-update-read-articles (caar groups) (cdr (pop groups))))))
408 (defsubst nnvirtual-marks (article marks)
409 "Return a list of mark types for ARTICLE."
412 (when (memq article (cdar marks))
413 (push (caar marks) out))
414 (setq marks (cdr marks)))
417 (defun nnvirtual-create-mapping ()
418 "Create an article mapping for the current group."
420 m marks list article unreads marks active
426 (when (and (setq active (gnus-activate-group g))
427 (> (cdr active) (car active)))
428 (setq unreads (gnus-list-of-unread-articles g)
429 marks (gnus-uncompress-marks
430 (gnus-info-marks (gnus-get-info g))))
432 (push (cons 'cache (gnus-cache-articles-in-group g))
434 (setq div (/ (float (car active))
435 (if (zerop (cdr active))
438 (list (* div (- n (car active)))
439 g n (and (memq n unreads) t)
440 (inline (nnvirtual-marks n marks))))
441 (gnus-uncompress-range active))))
442 nnvirtual-component-groups))
444 (< (car m1) (car m2)))))
446 (setq nnvirtual-mapping map)
447 ;; Set the virtual article numbers.
448 (while (setq m (pop map))
449 (setcar m (setq article (incf i))))))
453 ;;; nnvirtual.el ends here