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
37 (eval-when-compile (require 'cl))
39 (nnoo-declare nnvirtual)
41 (defvoo nnvirtual-always-rescan nil
42 "*If non-nil, always scan groups for unread articles when entering a group.
43 If this variable is nil (which is the default) and you read articles
44 in a component group after the virtual group has been activated, the
45 read articles from the component group will show up when you enter the
48 (defvoo nnvirtual-component-regexp nil
49 "*Regexp to match component groups.")
53 (defconst nnvirtual-version "nnvirtual 1.0")
55 (defvoo nnvirtual-current-group nil)
56 (defvoo nnvirtual-component-groups nil)
57 (defvoo nnvirtual-mapping nil)
59 (defvoo nnvirtual-status-string "")
62 (autoload 'gnus-cache-articles-in-group "gnus-cache"))
66 ;;; Interface functions.
68 (nnoo-define-basics nnvirtual)
70 (deffoo nnvirtual-retrieve-headers (articles &optional newsgroup
72 (when (nnvirtual-possibly-change-server server)
74 (set-buffer nntp-server-buffer)
76 (if (stringp (car articles))
78 (let ((vbuf (nnheader-set-temp-buffer
79 (get-buffer-create " *virtual headers*")))
80 (unfetched (mapcar (lambda (g) (list g))
81 nnvirtual-component-groups))
82 (system-name (system-name))
83 cgroup article result prefix)
85 (setq article (assq (pop articles) nnvirtual-mapping))
86 (when (and (setq cgroup (cadr article))
88 (gnus-find-method-for-group cgroup) t)
89 (gnus-request-group cgroup t))
90 (setq prefix (gnus-group-real-prefix cgroup))
91 (when (setq result (gnus-retrieve-headers
92 (list (caddr article)) cgroup nil))
93 (set-buffer nntp-server-buffer)
94 (if (zerop (buffer-size))
95 (nconc (assq cgroup unfetched) (list (caddr article)))
96 ;; If we got HEAD headers, we convert them into NOV
97 ;; headers. This is slow, inefficient and, come to think
98 ;; of it, downright evil. So sue me. I couldn't be
99 ;; bothered to write a header parse routine that could
100 ;; parse a mixed HEAD/NOV buffer.
101 (when (eq result 'headers)
102 (nnvirtual-convert-headers))
103 (goto-char (point-min))
106 (point) (progn (read nntp-server-buffer) (point)))
107 (princ (car article) (current-buffer))
110 "[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t")
111 (goto-char (match-end 0))
113 "\t" (save-excursion (end-of-line) (point)) t)
115 (while (= (char-after (1- (point))) ? )
121 (or (= (char-after (1- (point))) ?\t)
123 (insert "Xref: " system-name " " cgroup ":")
124 (princ (caddr article) (current-buffer))
126 (insert "Xref: " system-name " " cgroup ":")
127 (princ (caddr article) (current-buffer))
129 (if (not (string= "" prefix))
130 (while (re-search-forward
132 (save-excursion (end-of-line) (point)) t)
134 (goto-char (match-beginning 0))
137 (or (= (char-after (1- (point))) ?\t)
141 (goto-char (point-max))
142 (insert-buffer-substring nntp-server-buffer)))))
144 ;; In case some of the articles have expired or been
145 ;; cancelled, we have to mark them as read in the
148 (when (cdar unfetched)
149 (gnus-group-make-articles-read
150 (caar unfetched) (sort (cdar unfetched) '<)))
151 (setq unfetched (cdr unfetched)))
153 ;; The headers are ready for reading, so they are inserted into
154 ;; the nntp-server-buffer, which is where Gnus expects to find
158 (set-buffer nntp-server-buffer)
160 (insert-buffer-substring vbuf)
162 (kill-buffer vbuf)))))))
164 (deffoo nnvirtual-request-article (article &optional group server buffer)
165 (when (and (nnvirtual-possibly-change-server server)
167 (let* ((amap (assq article nnvirtual-mapping))
168 (cgroup (cadr amap)))
171 (nnheader-report 'nnvirtual "No such article: %s" article))
172 ((not (gnus-check-group cgroup))
174 'nnvirtual "Can't open server where %s exists" cgroup))
175 ((not (gnus-request-group cgroup t))
176 (nnheader-report 'nnvirtual "Can't open component group %s" cgroup))
181 (gnus-request-article-this-buffer (caddr amap) cgroup))
182 (gnus-request-article (caddr amap) cgroup)))))))
184 (deffoo nnvirtual-open-server (server &optional defs)
185 (unless (assq 'nnvirtual-component-regexp defs)
186 (push `(nnvirtual-component-regexp ,server)
188 (nnoo-change-server 'nnvirtual server defs)
189 (if nnvirtual-component-groups
191 (setq nnvirtual-mapping nil)
192 ;; Go through the newsrc alist and find all component groups.
193 (let ((newsrc (cdr gnus-newsrc-alist))
195 (while (setq group (car (pop newsrc)))
196 (and (string-match nnvirtual-component-regexp group) ; Match
197 ;; Add this group to the list of component groups.
198 (setq nnvirtual-component-groups
200 (delete group nnvirtual-component-groups))))))
201 (if (not nnvirtual-component-groups)
202 (nnheader-report 'nnvirtual "No component groups: %s" server)
205 (deffoo nnvirtual-request-group (group &optional server dont-check)
206 (nnvirtual-possibly-change-server server)
208 ((null nnvirtual-component-groups)
209 (setq nnvirtual-current-group nil)
210 (nnheader-report 'nnvirtual "No component groups in %s" group))
213 (nnvirtual-create-mapping))
214 (setq nnvirtual-current-group group)
215 (let ((len (length nnvirtual-mapping)))
216 (nnheader-insert "211 %d 1 %d %s\n" len len group)))))
218 (deffoo nnvirtual-request-type (group &optional article)
221 (let ((mart (assq article nnvirtual-mapping)))
223 (gnus-request-type (cadr mart) (car mart))))))
225 (deffoo nnvirtual-request-update-mark (group article mark)
226 (let* ((nart (assq article nnvirtual-mapping))
228 ;; The component group might be a virtual group.
229 (nmark (gnus-request-update-mark cgroup (caddr nart) mark)))
230 (when (and (= mark nmark)
231 (gnus-group-auto-expirable-p cgroup))
232 (setq mark gnus-expirable-mark)))
235 (deffoo nnvirtual-close-group (group &optional server)
236 (when (nnvirtual-possibly-change-server server)
237 ;; Copy (un)read articles.
238 (nnvirtual-update-reads)
239 ;; We copy the marks from this group to the component
241 (nnvirtual-update-marked))
244 (deffoo nnvirtual-request-list (&optional server)
245 (nnheader-report 'nnvirtual "LIST is not implemented."))
247 (deffoo nnvirtual-request-newgroups (date &optional server)
248 (nnheader-report 'nnvirtual "NEWGROUPS is not supported."))
250 (deffoo nnvirtual-request-list-newsgroups (&optional server)
251 (nnheader-report 'nnvirtual "LIST NEWSGROUPS is not implemented."))
253 (deffoo nnvirtual-request-update-info (group info &optional server)
254 (when (nnvirtual-possibly-change-server server)
255 (let ((map nnvirtual-mapping)
256 (marks (mapcar (lambda (m) (list (cdr m))) gnus-article-mark-lists))
258 ;; Go through the mapping.
260 (unless (nth 3 (setq m (pop map)))
262 (push (car m) reads))
264 (when (setq mr (nth 4 m))
266 (setcdr (setq op (assq (pop mr) marks)) (cons (car m) (cdr op))))))
267 ;; Compress the marks and the reads.
270 (setcdr (car mr) (gnus-compress-sequence (sort (cdr (pop mr)) '<))))
271 (setcar (cddr info) (gnus-compress-sequence (nreverse reads)))
272 ;; Remove empty marks lists.
273 (while (and marks (not (cdar marks)))
274 (setq marks (cdr marks)))
279 (setcdr mr (cddr mr))))
281 ;; Enter these new marks into the info of the group.
283 (setcar (nthcdr 3 info) marks)
284 ;; Add the marks lists to the end of the info.
286 (setcdr (nthcdr 2 info) (list marks))))
289 (deffoo nnvirtual-catchup-group (group &optional server all)
290 (nnvirtual-possibly-change-server server)
291 (let ((gnus-group-marked nnvirtual-component-groups)
292 (gnus-expert-user t))
293 ;; Make sure all groups are activated.
296 (when (not (numberp (car (gnus-gethash g gnus-newsrc-hashtb))))
297 (gnus-activate-group g)))
298 nnvirtual-component-groups)
300 (set-buffer gnus-group-buffer)
301 (gnus-group-catchup-current nil all))))
303 (deffoo nnvirtual-find-group-art (group article)
304 "Return the real group and article for virtual GROUP and ARTICLE."
305 (let ((mart (assq article nnvirtual-mapping)))
307 (cons (cadr mart) (caddr mart)))))
310 ;;; Internal functions.
312 (defun nnvirtual-convert-headers ()
313 "Convert HEAD headers into NOV headers."
315 (set-buffer nntp-server-buffer)
316 (let* ((dependencies (make-vector 100 0))
317 (headers (gnus-get-newsgroup-headers dependencies))
320 (while (setq header (pop headers))
321 (insert (int-to-string (mail-header-number header)) "\t"
322 (or (mail-header-subject header) "") "\t"
323 (or (mail-header-from header) "") "\t"
324 (or (mail-header-date header) "") "\t"
325 (or (mail-header-id header) "") "\t"
326 (or (mail-header-references header) "") "\t"
327 (int-to-string (or (mail-header-chars header) 0)) "\t"
328 (int-to-string (or (mail-header-lines header) 0)) "\t"
329 (if (mail-header-xref header)
330 (concat "Xref: " (mail-header-xref header) "\t")
333 (defun nnvirtual-possibly-change-server (server)
335 (nnoo-current-server-p 'nnvirtual server)
336 (nnvirtual-open-server server)))
338 (defun nnvirtual-update-marked ()
339 "Copy marks from the virtual group to the component groups."
340 (let ((mark-lists gnus-article-mark-lists)
341 (marks (gnus-info-marks (gnus-get-info (nnvirtual-current-group))))
342 type list mart cgroups)
343 (while (setq type (cdr (pop mark-lists)))
344 (setq list (gnus-uncompress-range (cdr (assq type marks))))
346 (mapcar (lambda (g) (list g)) nnvirtual-component-groups))
348 (nconc (assoc (cadr (setq mart (assq (pop list) nnvirtual-mapping)))
350 (list (caddr mart))))
352 (gnus-add-marked-articles
353 (caar cgroups) type (cdar cgroups) nil t)
354 (gnus-group-update-group (car (pop cgroups)) t)))))
356 (defun nnvirtual-update-reads ()
357 "Copy (un)reads from the current group to the component groups."
358 (let ((groups (mapcar (lambda (g) (list g)) nnvirtual-component-groups))
359 (articles (gnus-list-of-unread-articles
360 (nnvirtual-current-group)))
363 (setq m (assq (pop articles) nnvirtual-mapping))
364 (nconc (assoc (nth 1 m) groups) (list (nth 2 m))))
366 (gnus-update-read-articles (caar groups) (cdr (pop groups))))))
368 (defun nnvirtual-current-group ()
369 "Return the prefixed name of the current nnvirtual group."
370 (concat "nnvirtual:" nnvirtual-current-group))
372 (defsubst nnvirtual-marks (article marks)
373 "Return a list of mark types for ARTICLE."
376 (when (memq article (cdar marks))
377 (push (caar marks) out))
378 (setq marks (cdr marks)))
381 (defun nnvirtual-create-mapping ()
382 "Create an article mapping for the current group."
384 m marks list article unreads marks active
390 (when (and (setq active (gnus-activate-group g))
391 (> (cdr active) (car active)))
392 (setq unreads (gnus-list-of-unread-articles g)
393 marks (gnus-uncompress-marks
394 (gnus-info-marks (gnus-get-info g))))
396 (push (cons 'cache (gnus-cache-articles-in-group g))
398 (setq div (/ (float (car active))
399 (if (zerop (cdr active))
402 (list (* div (- n (car active)))
403 g n (and (memq n unreads) t)
404 (inline (nnvirtual-marks n marks))))
405 (gnus-uncompress-range active))))
406 (setq nnvirtual-component-groups
407 (delete (nnvirtual-current-group)
408 nnvirtual-component-groups))))
410 (< (car m1) (car m2)))))
412 (setq nnvirtual-mapping map)
413 ;; Set the virtual article numbers.
414 (while (setq m (pop map))
415 (setcar m (setq article (incf i))))))
419 ;;; nnvirtual.el ends here