Commit | Line | Data |
---|---|---|
41487370 | 1 | ;;; nnvirtual.el --- virtual newsgroups access for Gnus |
231f989b | 2 | ;; Copyright (C) 1994,95,96 Free Software Foundation, Inc. |
41487370 LMI |
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 | |
b578f267 EN |
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. | |
41487370 LMI |
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) | |
231f989b LMI |
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.") | |
41487370 LMI |
50 | |
51 | \f | |
52 | ||
231f989b | 53 | (defconst nnvirtual-version "nnvirtual 1.0") |
41487370 | 54 | |
231f989b LMI |
55 | (defvoo nnvirtual-current-group nil) |
56 | (defvoo nnvirtual-component-groups nil) | |
57 | (defvoo nnvirtual-mapping nil) | |
41487370 | 58 | |
231f989b | 59 | (defvoo nnvirtual-status-string "") |
41487370 | 60 | |
231f989b LMI |
61 | (eval-and-compile |
62 | (autoload 'gnus-cache-articles-in-group "gnus-cache")) | |
41487370 LMI |
63 | |
64 | \f | |
65 | ||
66 | ;;; Interface functions. | |
67 | ||
231f989b LMI |
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 | |
41487370 LMI |
157 | (save-excursion |
158 | (set-buffer nntp-server-buffer) | |
231f989b LMI |
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 | |
41487370 | 179 | (save-excursion |
231f989b LMI |
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)) | |
41487370 | 244 | t) |
231f989b LMI |
245 | |
246 | (deffoo nnvirtual-request-list (&optional server) | |
247 | (nnheader-report 'nnvirtual "LIST is not implemented.")) | |
41487370 | 248 | |
231f989b LMI |
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.")) | |
41487370 | 254 | |
231f989b LMI |
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) | |
41487370 | 301 | (save-excursion |
231f989b LMI |
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))))) | |
41487370 LMI |
310 | |
311 | \f | |
312 | ;;; Internal functions. | |
313 | ||
41487370 | 314 | (defun nnvirtual-convert-headers () |
231f989b | 315 | "Convert HEAD headers into NOV headers." |
41487370 LMI |
316 | (save-excursion |
317 | (set-buffer nntp-server-buffer) | |
231f989b LMI |
318 | (let* ((dependencies (make-vector 100 0)) |
319 | (headers (gnus-get-newsgroup-headers dependencies)) | |
41487370 LMI |
320 | header) |
321 | (erase-buffer) | |
231f989b LMI |
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))) | |
41487370 LMI |
329 | |
330 | (defun nnvirtual-update-marked () | |
231f989b LMI |
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 | |
41487370 | 344 | (gnus-add-marked-articles |
231f989b LMI |
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)))))) | |
41487370 LMI |
406 | |
407 | (provide 'nnvirtual) | |
408 | ||
409 | ;;; nnvirtual.el ends here |