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 (defvar nnvirtual-always-rescan nil
38 "*If non-nil, always scan groups for unread articles when entering a group.
39 If this variable is nil (which is the default) and you read articles
40 in a component group after the virtual group has been activated, the
41 read articles from the component group will show up when you enter the
46 (defconst nnvirtual-version "nnvirtual 1.0"
47 "Version number of this version of nnvirtual.")
49 (defvar nnvirtual-group-alist nil)
50 (defvar nnvirtual-current-group nil)
51 (defvar nnvirtual-component-groups nil)
52 (defvar nnvirtual-mapping nil)
54 (defvar nnvirtual-status-string "")
57 (autoload 'gnus-cache-articles-in-group "gnus-cache"))
61 ;;; Interface functions.
63 (defun nnvirtual-retrieve-headers (articles &optional newsgroup server fetch-old)
64 (when (nnvirtual-possibly-change-group newsgroup server t)
66 (if (stringp (car articles))
68 (let ((map nnvirtual-mapping)
69 (vbuf (nnheader-set-temp-buffer
70 (get-buffer-create " *virtual headers*")))
71 (unfetched (mapcar (lambda (g) (list g))
72 nnvirtual-component-groups))
73 beg cgroup active article result prefix)
75 (setq article (assq (pop articles) nnvirtual-mapping))
76 (setq cgroup (cadr article))
77 (gnus-request-group cgroup t)
78 (setq prefix (gnus-group-real-prefix cgroup))
79 (when (setq result (gnus-retrieve-headers
80 (list (caddr article)) cgroup))
81 (set-buffer nntp-server-buffer)
82 (if (zerop (buffer-size))
83 (nconc (assq cgroup unfetched) (list (caddr article)))
84 ;; If we got HEAD headers, we convert them into NOV
85 ;; headers. This is slow, inefficient and, come to think
86 ;; of it, downright evil. So sue me. I couldn't be
87 ;; bothered to write a header parse routine that could
88 ;; parse a mixed HEAD/NOV buffer.
89 (when (eq result 'headers)
90 (nnvirtual-convert-headers))
91 (goto-char (point-min))
94 (point) (progn (read nntp-server-buffer) (point)))
95 (insert (int-to-string (car article)))
98 "[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t")
99 (goto-char (match-end 0))
101 "\t" (save-excursion (end-of-line) (point)) t)
103 (while (= (char-after (1- (point))) ? )
109 (or (= (char-after (1- (point))) ?\t)
111 (insert (format "Xref: %s %s:%d\t" (system-name)
112 cgroup (caddr article))))
113 (if (not (string= "" prefix))
114 (while (re-search-forward
116 (save-excursion (end-of-line) (point)) t)
118 (goto-char (match-beginning 0))
121 (or (= (char-after (1- (point))) ?\t)
125 (goto-char (point-max))
126 (insert-buffer-substring nntp-server-buffer))))
128 ;; In case some of the articles have expired or been
129 ;; cancelled, we have to mark them as read in the
132 (when (cdar unfetched)
133 (gnus-group-make-articles-read
134 (caar unfetched) (sort (cdar unfetched) '<)))
135 (setq unfetched (cdr unfetched)))
137 ;; The headers are ready for reading, so they are inserted into
138 ;; the nntp-server-buffer, which is where Gnus expects to find
142 (set-buffer nntp-server-buffer)
144 (insert-buffer-substring vbuf)
146 (kill-buffer vbuf)))))))
148 (defun nnvirtual-open-server (server &optional something)
149 (nnheader-init-server-buffer))
151 (defun nnvirtual-close-server (&rest dum)
154 (defun nnvirtual-request-close ()
155 (setq nnvirtual-current-group nil
156 nnvirtual-component-groups nil
157 nnvirtual-mapping nil
158 nnvirtual-group-alist nil)
161 (defun nnvirtual-server-opened (&optional server)
162 (and nntp-server-buffer
163 (get-buffer nntp-server-buffer)))
165 (defun nnvirtual-status-message (&optional server)
166 nnvirtual-status-string)
168 (defun nnvirtual-request-article (article &optional group server buffer)
169 (when (and (nnvirtual-possibly-change-group group server t)
171 (let* ((amap (assq article nnvirtual-mapping))
172 (cgroup (cadr amap)))
175 (nnheader-report 'nnvirtual "No such article: %s" article))
176 ((not (gnus-check-group cgroup))
178 'nnvirtual "Can't open server where %s exists" cgroup))
179 ((not (gnus-request-group cgroup t))
180 (nnheader-report 'nnvirtual "Can't open component group %s" cgroup))
185 (gnus-request-article-this-buffer (caddr amap) cgroup))
186 (gnus-request-article (caddr amap) cgroup)))))))
188 (defun nnvirtual-request-group (group &optional server dont-check)
190 ((null (nnvirtual-possibly-change-group
192 (if nnvirtual-always-rescan nil dont-check)))
193 (setq nnvirtual-current-group nil)
194 (nnheader-report 'nnvirtual "No component groups in %s" group))
196 (let ((len (length nnvirtual-mapping)))
197 (nnheader-insert "211 %d 1 %d %s\n" len len group)))))
199 (defun nnvirtual-request-type (group &optional article)
200 (when (nnvirtual-possibly-change-group group nil t)
203 (let ((mart (assq article nnvirtual-mapping)))
205 (gnus-request-type (cadr mart) (car mart)))))))
207 (defun nnvirtual-request-update-mark (group article mark)
208 (when (nnvirtual-possibly-change-group group nil t)
209 (let* ((nart (assq article nnvirtual-mapping))
211 ;; The component group might be a virtual group.
212 (nmark (gnus-request-update-mark cgroup (caddr nart) mark)))
213 (when (and (= mark nmark)
214 (gnus-group-auto-expirable-p cgroup))
215 (setq mark gnus-expirable-mark))))
218 (defun nnvirtual-close-group (group &optional server)
219 (when (nnvirtual-possibly-change-group group server t)
220 ;; We copy the marks from this group to the component
222 (nnvirtual-update-marked)
223 ;; Reset all relevant variables.
224 (setq nnvirtual-current-group nil
225 nnvirtual-component-groups nil
226 nnvirtual-mapping nil)
227 (setq nnvirtual-group-alist
228 (delq (assoc group nnvirtual-group-alist) nnvirtual-group-alist)))
231 (defun nnvirtual-request-list (&optional server)
232 (nnheader-report 'nnvirtual "LIST is not implemented."))
234 (defun nnvirtual-request-newgroups (date &optional server)
235 (nnheader-report 'nnvirtual "NEWGROUPS is not supported."))
237 (defun nnvirtual-request-list-newsgroups (&optional server)
238 (nnheader-report 'nnvirtual "LIST NEWSGROUPS is not implemented."))
240 (defun nnvirtual-request-update-info (group info &optional server)
241 (when (nnvirtual-possibly-change-group group server)
242 (let ((map nnvirtual-mapping)
243 (marks (mapcar (lambda (m) (list (cdr m))) gnus-article-mark-lists))
248 (push (car m) reads))
249 (when (setq mr (nth 4 m))
251 (setcdr (setq op (assq (pop mr) marks)) (cons (car m) (cdr op))))))
254 (setcdr (car mr) (gnus-compress-sequence (sort (cdar mr) '<)))
256 (setcar (cddr info) (gnus-compress-sequence (nreverse reads)))
258 ;; Enter these new marks into the info of the group.
260 (setcar (nthcdr 3 info) marks)
261 ;; Add the marks lists to the end of the info.
263 (setcdr (nthcdr 2 info) (list marks))))
266 (defun nnvirtual-catchup-group (group &optional server all)
267 (nnvirtual-possibly-change-group group server t)
268 (let ((gnus-group-marked nnvirtual-component-groups)
269 (gnus-expert-user t))
271 (set-buffer gnus-group-buffer)
272 (gnus-group-catchup-current nil all))))
274 (defun nnvirtual-find-group-art (group article)
275 "Return the real group and article for virtual GROUP and ARTICLE."
276 (nnvirtual-possibly-change-group group nil t)
277 (let ((mart (assq article nnvirtual-mapping)))
278 (cons (cadr mart) (caddr mart))))
281 ;;; Internal functions.
283 (defun nnvirtual-convert-headers ()
284 "Convert HEAD headers into NOV headers."
286 (set-buffer nntp-server-buffer)
287 (let* ((dependencies (make-vector 100 0))
288 (headers (gnus-get-newsgroup-headers dependencies))
291 (while (setq header (pop headers))
292 (insert (int-to-string (mail-header-number header)) "\t"
293 (or (mail-header-subject header) "") "\t"
294 (or (mail-header-from header) "") "\t"
295 (or (mail-header-date header) "") "\t"
296 (or (mail-header-id header) "") "\t"
297 (or (mail-header-references header) "") "\t"
298 (int-to-string (or (mail-header-chars header) 0)) "\t"
299 (int-to-string (or (mail-header-lines header) 0)) "\t"
300 (if (mail-header-xref header)
301 (concat "Xref: " (mail-header-xref header) "\t")
304 (defun nnvirtual-possibly-change-group (group regexp &optional dont-check)
306 (unless (equal group nnvirtual-current-group)
307 (and (setq inf (assoc group nnvirtual-group-alist))
309 (string= (nth 3 inf) regexp)
311 (setq nnvirtual-current-group (car inf))
312 (setq nnvirtual-component-groups (nth 1 inf))
313 (setq nnvirtual-mapping (nth 2 inf)))))
317 (and inf (setq nnvirtual-group-alist
318 (delq inf nnvirtual-group-alist)))
319 (setq nnvirtual-mapping nil)
320 (setq nnvirtual-current-group group)
321 (let ((newsrc gnus-newsrc-alist)
322 (virt-group (gnus-group-prefixed-name
323 nnvirtual-current-group '(nnvirtual ""))))
324 (setq nnvirtual-component-groups nil)
326 (and (string-match regexp (car (car newsrc)))
327 (not (string= (car (car newsrc)) virt-group))
328 (setq nnvirtual-component-groups
329 (cons (car (car newsrc)) nnvirtual-component-groups)))
330 (setq newsrc (cdr newsrc))))
331 (if nnvirtual-component-groups
333 (nnvirtual-create-mapping)
334 (setq nnvirtual-group-alist
335 (cons (list group nnvirtual-component-groups
336 nnvirtual-mapping regexp)
337 nnvirtual-group-alist)))
338 (nnheader-report 'nnvirtual "No component groups: %s" group))))
339 nnvirtual-component-groups)
341 (defun nnvirtual-update-marked ()
342 "Copy marks from the virtual group to the component groups."
343 (let ((mark-lists gnus-article-mark-lists)
344 (uncompressed '(score bookmark))
345 type list calist mart cgroups)
347 (setq type (cdar mark-lists))
348 (when (setq list (symbol-value (intern (format "gnus-newsgroup-%s"
349 (car (pop mark-lists))))))
351 (mapcar (lambda (g) (list g)) nnvirtual-component-groups))
353 (nconc (assoc (cadr (setq mart (assq (pop list) nnvirtual-mapping)))
355 (list (caddr mart))))
358 (gnus-add-marked-articles
359 (caar cgroups) type (cdar cgroups) nil t)
360 (gnus-group-update-group (caar cgroups) t))
361 (setq cgroups (cdr cgroups)))))))
363 (defun nnvirtual-marks (article marks)
364 "Return a list of mark types for ARTICLE."
367 (when (memq article (cdar marks))
368 (push (caar marks) out))
369 (setq marks (cdr marks)))
372 (defun nnvirtual-create-mapping ()
373 "Create an article mapping for the current group."
380 (let* ((active (or (gnus-active g) (gnus-activate-group g)))
381 (unreads (and active (gnus-list-of-unread-articles
383 (marks (gnus-uncompress-marks
384 (gnus-info-marks (gnus-get-info g)))))
387 (push (cons 'cache (gnus-cache-articles-in-group g))
390 (setq div (/ (float (car active))
391 (if (zerop (cdr active))
394 (list (* div (- n (car active)))
395 g n (and (memq n unreads) t)
396 (nnvirtual-marks n marks)))
397 (gnus-uncompress-range active))))))
398 nnvirtual-component-groups))
400 (< (car m1) (car m2)))))
402 (setq nnvirtual-mapping map)
404 (setcar (pop map) (incf i)))))
408 ;;; nnvirtual.el ends here