|
0
|
1 ;;; nnvirtual.el --- virtual newsgroups access for Gnus
|
|
|
2 ;; Copyright (C) 1994,95,96 Free Software Foundation, Inc.
|
|
|
3
|
|
|
4 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
|
|
|
5 ;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
|
|
|
6 ;; Keywords: news
|
|
|
7
|
|
|
8 ;; This file is part of GNU Emacs.
|
|
|
9
|
|
|
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)
|
|
|
13 ;; any later version.
|
|
|
14
|
|
|
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.
|
|
|
19
|
|
|
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.
|
|
|
24
|
|
|
25 ;;; Commentary:
|
|
|
26
|
|
|
27 ;; The other access methods (nntp, nnspool, etc) are general news
|
|
|
28 ;; access methods. This module relies on Gnus and can not be used
|
|
|
29 ;; separately.
|
|
|
30
|
|
|
31 ;;; Code:
|
|
|
32
|
|
|
33 (require 'nntp)
|
|
|
34 (require 'nnheader)
|
|
|
35 (require 'gnus)
|
|
|
36 (require 'nnoo)
|
|
|
37 (eval-when-compile (require 'cl))
|
|
|
38
|
|
|
39 (nnoo-declare nnvirtual)
|
|
|
40
|
|
|
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
|
|
|
46 virtual group.")
|
|
|
47
|
|
|
48 (defvoo nnvirtual-component-regexp nil
|
|
|
49 "*Regexp to match component groups.")
|
|
|
50
|
|
|
51
|
|
|
52
|
|
|
53 (defconst nnvirtual-version "nnvirtual 1.0")
|
|
|
54
|
|
|
55 (defvoo nnvirtual-current-group nil)
|
|
|
56 (defvoo nnvirtual-component-groups nil)
|
|
|
57 (defvoo nnvirtual-mapping nil)
|
|
|
58
|
|
|
59 (defvoo nnvirtual-status-string "")
|
|
|
60
|
|
|
61 (eval-and-compile
|
|
|
62 (autoload 'gnus-cache-articles-in-group "gnus-cache"))
|
|
|
63
|
|
|
64
|
|
|
65
|
|
|
66 ;;; Interface functions.
|
|
|
67
|
|
|
68 (nnoo-define-basics nnvirtual)
|
|
|
69
|
|
|
70 (deffoo nnvirtual-retrieve-headers (articles &optional newsgroup
|
|
|
71 server fetch-old)
|
|
|
72 (when (nnvirtual-possibly-change-server server)
|
|
|
73 (save-excursion
|
|
|
74 (set-buffer nntp-server-buffer)
|
|
|
75 (erase-buffer)
|
|
|
76 (if (stringp (car articles))
|
|
|
77 'headers
|
|
|
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)
|
|
|
84 (while articles
|
|
|
85 (setq article (assq (pop articles) nnvirtual-mapping))
|
|
|
86 (when (and (setq cgroup (cadr article))
|
|
|
87 (gnus-check-server
|
|
|
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))
|
|
|
104 (while (not (eobp))
|
|
|
105 (delete-region
|
|
|
106 (point) (progn (read nntp-server-buffer) (point)))
|
|
|
107 (princ (car article) (current-buffer))
|
|
|
108 (beginning-of-line)
|
|
|
109 (looking-at
|
|
|
110 "[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t")
|
|
|
111 (goto-char (match-end 0))
|
|
|
112 (or (search-forward
|
|
|
113 "\t" (save-excursion (end-of-line) (point)) t)
|
|
|
114 (end-of-line))
|
|
|
115 (while (= (char-after (1- (point))) ? )
|
|
|
116 (forward-char -1)
|
|
|
117 (delete-char 1))
|
|
|
118 (if (eolp)
|
|
|
119 (progn
|
|
|
120 (end-of-line)
|
|
|
121 (or (= (char-after (1- (point))) ?\t)
|
|
|
122 (insert ?\t))
|
|
|
123 (insert "Xref: " system-name " " cgroup ":")
|
|
|
124 (princ (caddr article) (current-buffer))
|
|
|
125 (insert "\t"))
|
|
|
126 (insert "Xref: " system-name " " cgroup ":")
|
|
|
127 (princ (caddr article) (current-buffer))
|
|
|
128 (insert " ")
|
|
|
129 (if (not (string= "" prefix))
|
|
|
130 (while (re-search-forward
|
|
|
131 "[^ ]+:[0-9]+"
|
|
|
132 (save-excursion (end-of-line) (point)) t)
|
|
|
133 (save-excursion
|
|
|
134 (goto-char (match-beginning 0))
|
|
|
135 (insert prefix))))
|
|
|
136 (end-of-line)
|
|
|
137 (or (= (char-after (1- (point))) ?\t)
|
|
|
138 (insert ?\t)))
|
|
|
139 (forward-line 1))
|
|
|
140 (set-buffer vbuf)
|
|
|
141 (goto-char (point-max))
|
|
|
142 (insert-buffer-substring nntp-server-buffer)))))
|
|
|
143
|
|
|
144 ;; In case some of the articles have expired or been
|
|
|
145 ;; cancelled, we have to mark them as read in the
|
|
|
146 ;; component group.
|
|
|
147 (while unfetched
|
|
|
148 (when (cdar unfetched)
|
|
|
149 (gnus-group-make-articles-read
|
|
|
150 (caar unfetched) (sort (cdar unfetched) '<)))
|
|
|
151 (setq unfetched (cdr unfetched)))
|
|
|
152
|
|
|
153 ;; The headers are ready for reading, so they are inserted into
|
|
|
154 ;; the nntp-server-buffer, which is where Gnus expects to find
|
|
|
155 ;; them.
|
|
|
156 (prog1
|
|
|
157 (save-excursion
|
|
|
158 (set-buffer nntp-server-buffer)
|
|
|
159 (erase-buffer)
|
|
|
160 (insert-buffer-substring vbuf)
|
|
|
161 'nov)
|
|
|
162 (kill-buffer vbuf)))))))
|
|
|
163
|
|
|
164 (deffoo nnvirtual-request-article (article &optional group server buffer)
|
|
|
165 (when (and (nnvirtual-possibly-change-server server)
|
|
|
166 (numberp article))
|
|
|
167 (let* ((amap (assq article nnvirtual-mapping))
|
|
|
168 (cgroup (cadr amap)))
|
|
|
169 (cond
|
|
|
170 ((not amap)
|
|
|
171 (nnheader-report 'nnvirtual "No such article: %s" article))
|
|
|
172 ((not (gnus-check-group cgroup))
|
|
|
173 (nnheader-report
|
|
|
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))
|
|
|
177 (t
|
|
|
178 (if buffer
|
|
|
179 (save-excursion
|
|
|
180 (set-buffer buffer)
|
|
|
181 (gnus-request-article-this-buffer (caddr amap) cgroup))
|
|
|
182 (gnus-request-article (caddr amap) cgroup)))))))
|
|
|
183
|
|
|
184 (deffoo nnvirtual-open-server (server &optional defs)
|
|
|
185 (unless (assq 'nnvirtual-component-regexp defs)
|
|
|
186 (push `(nnvirtual-component-regexp ,server)
|
|
|
187 defs))
|
|
|
188 (nnoo-change-server 'nnvirtual server defs)
|
|
|
189 (if nnvirtual-component-groups
|
|
|
190 t
|
|
|
191 (setq nnvirtual-mapping nil)
|
|
|
192 ;; Go through the newsrc alist and find all component groups.
|
|
|
193 (let ((newsrc (cdr gnus-newsrc-alist))
|
|
|
194 group)
|
|
|
195 (while (setq group (car (pop newsrc)))
|
|
|
196 (when (string-match nnvirtual-component-regexp group) ; Match
|
|
|
197 ;; Add this group to the list of component groups.
|
|
|
198 (setq nnvirtual-component-groups
|
|
|
199 (cons group (delete group nnvirtual-component-groups))))))
|
|
|
200 (if (not nnvirtual-component-groups)
|
|
|
201 (nnheader-report 'nnvirtual "No component groups: %s" server)
|
|
|
202 t)))
|
|
|
203
|
|
|
204 (deffoo nnvirtual-request-group (group &optional server dont-check)
|
|
|
205 (nnvirtual-possibly-change-server server)
|
|
|
206 (setq nnvirtual-component-groups
|
|
|
207 (delete (nnvirtual-current-group) nnvirtual-component-groups))
|
|
|
208 (cond
|
|
|
209 ((null nnvirtual-component-groups)
|
|
|
210 (setq nnvirtual-current-group nil)
|
|
|
211 (nnheader-report 'nnvirtual "No component groups in %s" group))
|
|
|
212 (t
|
|
|
213 (unless dont-check
|
|
|
214 (nnvirtual-create-mapping))
|
|
|
215 (setq nnvirtual-current-group group)
|
|
|
216 (let ((len (length nnvirtual-mapping)))
|
|
|
217 (nnheader-insert "211 %d 1 %d %s\n" len len group)))))
|
|
|
218
|
|
|
219 (deffoo nnvirtual-request-type (group &optional article)
|
|
|
220 (if (not article)
|
|
|
221 'unknown
|
|
|
222 (let ((mart (assq article nnvirtual-mapping)))
|
|
|
223 (when mart
|
|
|
224 (gnus-request-type (cadr mart) (car mart))))))
|
|
|
225
|
|
|
226 (deffoo nnvirtual-request-update-mark (group article mark)
|
|
|
227 (let* ((nart (assq article nnvirtual-mapping))
|
|
|
228 (cgroup (cadr nart))
|
|
|
229 ;; The component group might be a virtual group.
|
|
|
230 (nmark (gnus-request-update-mark cgroup (caddr nart) mark)))
|
|
|
231 (when (and nart
|
|
|
232 (= mark nmark)
|
|
|
233 (gnus-group-auto-expirable-p cgroup))
|
|
|
234 (setq mark gnus-expirable-mark)))
|
|
|
235 mark)
|
|
|
236
|
|
|
237 (deffoo nnvirtual-close-group (group &optional server)
|
|
|
238 (when (nnvirtual-possibly-change-server server)
|
|
|
239 ;; Copy (un)read articles.
|
|
|
240 (nnvirtual-update-reads)
|
|
|
241 ;; We copy the marks from this group to the component
|
|
|
242 ;; groups here.
|
|
|
243 (nnvirtual-update-marked))
|
|
|
244 t)
|
|
|
245
|
|
|
246 (deffoo nnvirtual-request-list (&optional server)
|
|
|
247 (nnheader-report 'nnvirtual "LIST is not implemented."))
|
|
|
248
|
|
|
249 (deffoo nnvirtual-request-newgroups (date &optional server)
|
|
|
250 (nnheader-report 'nnvirtual "NEWGROUPS is not supported."))
|
|
|
251
|
|
|
252 (deffoo nnvirtual-request-list-newsgroups (&optional server)
|
|
|
253 (nnheader-report 'nnvirtual "LIST NEWSGROUPS is not implemented."))
|
|
|
254
|
|
|
255 (deffoo nnvirtual-request-update-info (group info &optional server)
|
|
|
256 (when (nnvirtual-possibly-change-server server)
|
|
|
257 (let ((map nnvirtual-mapping)
|
|
|
258 (marks (mapcar (lambda (m) (list (cdr m))) gnus-article-mark-lists))
|
|
|
259 reads mr m op)
|
|
|
260 ;; Go through the mapping.
|
|
|
261 (while map
|
|
|
262 (unless (nth 3 (setq m (pop map)))
|
|
|
263 ;; Read article.
|
|
|
264 (push (car m) reads))
|
|
|
265 ;; Copy marks.
|
|
|
266 (when (setq mr (nth 4 m))
|
|
|
267 (while mr
|
|
|
268 (setcdr (setq op (assq (pop mr) marks)) (cons (car m) (cdr op))))))
|
|
|
269 ;; Compress the marks and the reads.
|
|
|
270 (setq mr marks)
|
|
|
271 (while mr
|
|
|
272 (setcdr (car mr) (gnus-compress-sequence (sort (cdr (pop mr)) '<))))
|
|
|
273 (setcar (cddr info) (gnus-compress-sequence (nreverse reads)))
|
|
|
274 ;; Remove empty marks lists.
|
|
|
275 (while (and marks (not (cdar marks)))
|
|
|
276 (setq marks (cdr marks)))
|
|
|
277 (setq mr marks)
|
|
|
278 (while (cdr mr)
|
|
|
279 (if (cdadr mr)
|
|
|
280 (setq mr (cdr mr))
|
|
|
281 (setcdr mr (cddr mr))))
|
|
|
282
|
|
|
283 ;; Enter these new marks into the info of the group.
|
|
|
284 (if (nthcdr 3 info)
|
|
|
285 (setcar (nthcdr 3 info) marks)
|
|
|
286 ;; Add the marks lists to the end of the info.
|
|
|
287 (when marks
|
|
|
288 (setcdr (nthcdr 2 info) (list marks))))
|
|
|
289 t)))
|
|
|
290
|
|
|
291 (deffoo nnvirtual-catchup-group (group &optional server all)
|
|
|
292 (nnvirtual-possibly-change-server server)
|
|
|
293 (let ((gnus-group-marked (copy-sequence nnvirtual-component-groups))
|
|
|
294 (gnus-expert-user t))
|
|
|
295 ;; Make sure all groups are activated.
|
|
|
296 (mapcar
|
|
|
297 (lambda (g)
|
|
|
298 (when (not (numberp (car (gnus-gethash g gnus-newsrc-hashtb))))
|
|
|
299 (gnus-activate-group g)))
|
|
|
300 nnvirtual-component-groups)
|
|
|
301 (save-excursion
|
|
|
302 (set-buffer gnus-group-buffer)
|
|
|
303 (gnus-group-catchup-current nil all))))
|
|
|
304
|
|
|
305 (deffoo nnvirtual-find-group-art (group article)
|
|
|
306 "Return the real group and article for virtual GROUP and ARTICLE."
|
|
|
307 (let ((mart (assq article nnvirtual-mapping)))
|
|
|
308 (when mart
|
|
|
309 (cons (cadr mart) (caddr mart)))))
|
|
|
310
|
|
|
311
|
|
|
312 ;;; Internal functions.
|
|
|
313
|
|
|
314 (defun nnvirtual-convert-headers ()
|
|
|
315 "Convert HEAD headers into NOV headers."
|
|
|
316 (save-excursion
|
|
|
317 (set-buffer nntp-server-buffer)
|
|
|
318 (let* ((dependencies (make-vector 100 0))
|
|
|
319 (headers (gnus-get-newsgroup-headers dependencies))
|
|
|
320 header)
|
|
|
321 (erase-buffer)
|
|
|
322 (while (setq header (pop headers))
|
|
|
323 (nnheader-insert-nov header)))))
|
|
|
324
|
|
|
325 (defun nnvirtual-possibly-change-server (server)
|
|
|
326 (or (not server)
|
|
|
327 (nnoo-current-server-p 'nnvirtual server)
|
|
|
328 (nnvirtual-open-server server)))
|
|
|
329
|
|
|
330 (defun nnvirtual-update-marked ()
|
|
|
331 "Copy marks from the virtual group to the component groups."
|
|
|
332 (let ((mark-lists gnus-article-mark-lists)
|
|
|
333 (marks (gnus-info-marks (gnus-get-info (nnvirtual-current-group))))
|
|
|
334 type list mart cgroups)
|
|
|
335 (while (setq type (cdr (pop mark-lists)))
|
|
|
336 (setq list (gnus-uncompress-range (cdr (assq type marks))))
|
|
|
337 (setq cgroups
|
|
|
338 (mapcar (lambda (g) (list g)) nnvirtual-component-groups))
|
|
|
339 (while list
|
|
|
340 (nconc (assoc (cadr (setq mart (assq (pop list) nnvirtual-mapping)))
|
|
|
341 cgroups)
|
|
|
342 (list (caddr mart))))
|
|
|
343 (while cgroups
|
|
|
344 (gnus-add-marked-articles
|
|
|
345 (caar cgroups) type (cdar cgroups) nil t)
|
|
|
346 (gnus-group-update-group (car (pop cgroups)) t)))))
|
|
|
347
|
|
|
348 (defun nnvirtual-update-reads ()
|
|
|
349 "Copy (un)reads from the current group to the component groups."
|
|
|
350 (let ((groups (mapcar (lambda (g) (list g)) nnvirtual-component-groups))
|
|
|
351 (articles (gnus-list-of-unread-articles
|
|
|
352 (nnvirtual-current-group)))
|
|
|
353 m)
|
|
|
354 (while articles
|
|
|
355 (setq m (assq (pop articles) nnvirtual-mapping))
|
|
|
356 (nconc (assoc (nth 1 m) groups) (list (nth 2 m))))
|
|
|
357 (while groups
|
|
|
358 (gnus-update-read-articles (caar groups) (cdr (pop groups))))))
|
|
|
359
|
|
|
360 (defun nnvirtual-current-group ()
|
|
|
361 "Return the prefixed name of the current nnvirtual group."
|
|
|
362 (concat "nnvirtual:" nnvirtual-current-group))
|
|
|
363
|
|
|
364 (defsubst nnvirtual-marks (article marks)
|
|
|
365 "Return a list of mark types for ARTICLE."
|
|
|
366 (let (out)
|
|
|
367 (while marks
|
|
|
368 (when (memq article (cdar marks))
|
|
|
369 (push (caar marks) out))
|
|
|
370 (setq marks (cdr marks)))
|
|
|
371 out))
|
|
|
372
|
|
|
373 (defun nnvirtual-create-mapping ()
|
|
|
374 "Create an article mapping for the current group."
|
|
|
375 (let* ((div nil)
|
|
|
376 m marks list article unreads marks active
|
|
|
377 (map (sort
|
|
|
378 (apply
|
|
|
379 'nconc
|
|
|
380 (mapcar
|
|
|
381 (lambda (g)
|
|
|
382 (when (and (setq active (gnus-activate-group g))
|
|
|
383 (> (cdr active) (car active)))
|
|
|
384 (setq unreads (gnus-list-of-unread-articles g)
|
|
|
385 marks (gnus-uncompress-marks
|
|
|
386 (gnus-info-marks (gnus-get-info g))))
|
|
|
387 (when gnus-use-cache
|
|
|
388 (push (cons 'cache (gnus-cache-articles-in-group g))
|
|
|
389 marks))
|
|
|
390 (setq div (/ (float (car active))
|
|
|
391 (if (zerop (cdr active))
|
|
|
392 1 (cdr active))))
|
|
|
393 (mapcar (lambda (n)
|
|
|
394 (list (* div (- n (car active)))
|
|
|
395 g n (and (memq n unreads) t)
|
|
|
396 (inline (nnvirtual-marks n marks))))
|
|
|
397 (gnus-uncompress-range active))))
|
|
|
398 nnvirtual-component-groups))
|
|
|
399 (lambda (m1 m2)
|
|
|
400 (< (car m1) (car m2)))))
|
|
|
401 (i 0))
|
|
|
402 (setq nnvirtual-mapping map)
|
|
|
403 ;; Set the virtual article numbers.
|
|
|
404 (while (setq m (pop map))
|
|
|
405 (setcar m (setq article (incf i))))))
|
|
|
406
|
|
|
407 (provide 'nnvirtual)
|
|
|
408
|
|
|
409 ;;; nnvirtual.el ends here
|
