Mercurial > emacs
comparison lisp/nnvirtual.el @ 13401:178d730efae2
entered into RCS
author | Lars Magne Ingebrigtsen <larsi@gnus.org> |
---|---|
date | Sat, 04 Nov 1995 03:54:42 +0000 |
parents | |
children | 83f275dcd93a |
comparison
equal
deleted
inserted
replaced
13400:4a57cda2a39a | 13401:178d730efae2 |
---|---|
1 ;;; nnvirtual.el --- virtual newsgroups access for Gnus | |
2 ;; Copyright (C) 1994,95 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 | |
22 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. | |
23 | |
24 ;;; Commentary: | |
25 | |
26 ;; The other access methods (nntp, nnspool, etc) are general news | |
27 ;; access methods. This module relies on Gnus and can not be used | |
28 ;; separately. | |
29 | |
30 ;;; Code: | |
31 | |
32 (require 'nntp) | |
33 (require 'nnheader) | |
34 (require 'gnus) | |
35 | |
36 | |
37 | |
38 (defconst nnvirtual-version "nnvirtual 1.0" | |
39 "Version number of this version of nnvirtual.") | |
40 | |
41 (defvar nnvirtual-group-alist nil) | |
42 (defvar nnvirtual-current-group nil) | |
43 (defvar nnvirtual-current-groups nil) | |
44 (defvar nnvirtual-current-mapping nil) | |
45 | |
46 (defvar nnvirtual-do-not-open nil) | |
47 | |
48 (defvar nnvirtual-status-string "") | |
49 | |
50 | |
51 | |
52 ;;; Interface functions. | |
53 | |
54 (defun nnvirtual-retrieve-headers (sequence &optional newsgroup server) | |
55 "Retrieve the headers for the articles in SEQUENCE." | |
56 (nnvirtual-possibly-change-newsgroups newsgroup server t) | |
57 (save-excursion | |
58 (set-buffer (get-buffer-create "*virtual headers*")) | |
59 (buffer-disable-undo (current-buffer)) | |
60 (erase-buffer) | |
61 (if (stringp (car sequence)) | |
62 'headers | |
63 (let ((map nnvirtual-current-mapping) | |
64 (offset 0) | |
65 articles beg group active top article result prefix | |
66 fetched-articles group-method) | |
67 (while sequence | |
68 (while (< (car (car map)) (car sequence)) | |
69 (setq offset (car (car map))) | |
70 (setq map (cdr map))) | |
71 (setq top (car (car map))) | |
72 (setq group (nth 1 (car map))) | |
73 (setq prefix (gnus-group-real-prefix group)) | |
74 (setq active (nth 2 (car map))) | |
75 (setq articles nil) | |
76 (while (and sequence (<= (car sequence) top)) | |
77 (setq articles (cons (- (+ active (car sequence)) offset) | |
78 articles)) | |
79 (setq sequence (cdr sequence))) | |
80 (setq articles (nreverse articles)) | |
81 (if (and articles | |
82 (setq result | |
83 (progn | |
84 (setq group-method | |
85 (gnus-find-method-for-group group)) | |
86 (and (or (gnus-server-opened group-method) | |
87 (gnus-open-server group-method)) | |
88 (gnus-request-group group t) | |
89 (gnus-retrieve-headers articles group))))) | |
90 (save-excursion | |
91 (set-buffer nntp-server-buffer) | |
92 ;; If we got HEAD headers, we convert them into NOV | |
93 ;; headers. This is slow, inefficient and, come to think | |
94 ;; of it, downright evil. So sue me. I couldn't be | |
95 ;; bothered to write a header parse routine that could | |
96 ;; parse a mixed HEAD/NOV buffer. | |
97 (and (eq result 'headers) (nnvirtual-convert-headers)) | |
98 (goto-char (point-min)) | |
99 (setq fetched-articles nil) | |
100 (while (not (eobp)) | |
101 (setq beg (point) | |
102 article (read nntp-server-buffer) | |
103 fetched-articles (cons article fetched-articles)) | |
104 (delete-region beg (point)) | |
105 (insert (int-to-string (+ (- article active) offset))) | |
106 (beginning-of-line) | |
107 (looking-at | |
108 "[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t") | |
109 (goto-char (match-end 0)) | |
110 (or (search-forward | |
111 "\t" (save-excursion (end-of-line) (point)) t) | |
112 (end-of-line)) | |
113 (while (= (char-after (1- (point))) ? ) | |
114 (forward-char -1) | |
115 (delete-char 1)) | |
116 (if (eolp) | |
117 (progn | |
118 (end-of-line) | |
119 (or (= (char-after (1- (point))) ?\t) | |
120 (insert ?\t)) | |
121 (insert (format "Xref: %s %s:%d\t" (system-name) | |
122 group article))) | |
123 (if (not (string= "" prefix)) | |
124 (while (re-search-forward | |
125 "[^ ]+:[0-9]+" | |
126 (save-excursion (end-of-line) (point)) t) | |
127 (save-excursion | |
128 (goto-char (match-beginning 0)) | |
129 (insert prefix)))) | |
130 (end-of-line) | |
131 (or (= (char-after (1- (point))) ?\t) | |
132 (insert ?\t))) | |
133 (forward-line 1)))) | |
134 (goto-char (point-max)) | |
135 (insert-buffer-substring nntp-server-buffer) | |
136 ;; We have now massaged and inserted the headers from one | |
137 ;; group. In case some of the articles have expired or been | |
138 ;; cancelled, we have to mark them as read in the component | |
139 ;; group. | |
140 (let ((unfetched (gnus-sorted-complement | |
141 articles (nreverse fetched-articles)))) | |
142 (and unfetched | |
143 (gnus-group-make-articles-read group unfetched nil)))) | |
144 ;; The headers are ready for reading, so they are inserted into | |
145 ;; the nntp-server-buffer, which is where Gnus expects to find | |
146 ;; them. | |
147 (prog1 | |
148 (save-excursion | |
149 (set-buffer nntp-server-buffer) | |
150 (erase-buffer) | |
151 (insert-buffer-substring "*virtual headers*") | |
152 'nov) | |
153 (kill-buffer (current-buffer))))))) | |
154 | |
155 (defun nnvirtual-open-server (newsgroups &optional something) | |
156 "Open a virtual newsgroup that contains NEWSGROUPS." | |
157 (nnheader-init-server-buffer)) | |
158 | |
159 (defun nnvirtual-close-server (&rest dum) | |
160 "Close news server." | |
161 t) | |
162 | |
163 (defun nnvirtual-request-close () | |
164 (setq nnvirtual-current-group nil | |
165 nnvirtual-current-groups nil | |
166 nnvirtual-current-mapping nil | |
167 nnvirtual-group-alist nil) | |
168 t) | |
169 | |
170 (defun nnvirtual-server-opened (&optional server) | |
171 "Return server process status, T or NIL. | |
172 If the stream is opened, return T, otherwise return NIL." | |
173 (and nntp-server-buffer | |
174 (get-buffer nntp-server-buffer))) | |
175 | |
176 (defun nnvirtual-status-message (&optional server) | |
177 "Return server status response as string." | |
178 nnvirtual-status-string) | |
179 | |
180 (defun nnvirtual-request-article (article &optional newsgroup server buffer) | |
181 "Select article by message number." | |
182 (nnvirtual-possibly-change-newsgroups newsgroup server t) | |
183 (and (numberp article) | |
184 (let ((map nnvirtual-current-mapping) | |
185 (offset 0) | |
186 group-method) | |
187 (while (< (car (car map)) article) | |
188 (setq offset (car (car map))) | |
189 (setq map (cdr map))) | |
190 (setq group-method (gnus-find-method-for-group (nth 1 (car map)))) | |
191 (or (gnus-server-opened group-method) | |
192 (gnus-open-server group-method)) | |
193 (gnus-request-group (nth 1 (car map)) t) | |
194 (gnus-request-article (- (+ (nth 2 (car map)) article) offset) | |
195 (nth 1 (car map)) buffer)))) | |
196 | |
197 (defun nnvirtual-request-group (group &optional server dont-check) | |
198 "Make GROUP the current newsgroup." | |
199 (nnvirtual-possibly-change-newsgroups group server dont-check) | |
200 (let ((map nnvirtual-current-mapping)) | |
201 (save-excursion | |
202 (set-buffer nntp-server-buffer) | |
203 (erase-buffer) | |
204 (if map | |
205 (progn | |
206 (while (cdr map) | |
207 (setq map (cdr map))) | |
208 (insert (format "211 %d 1 %d %s\n" (car (car map)) | |
209 (car (car map)) group)) | |
210 t) | |
211 (setq nnvirtual-status-string "No component groups") | |
212 (setq nnvirtual-current-group nil) | |
213 nil)))) | |
214 | |
215 (defun nnvirtual-close-group (group &optional server) | |
216 (if (not nnvirtual-current-group) | |
217 () | |
218 (nnvirtual-possibly-change-newsgroups group server t) | |
219 (nnvirtual-update-marked) | |
220 (setq nnvirtual-current-group nil | |
221 nnvirtual-current-groups nil | |
222 nnvirtual-current-mapping nil) | |
223 (setq nnvirtual-group-alist | |
224 (delq (assoc group nnvirtual-group-alist) nnvirtual-group-alist)))) | |
225 | |
226 (defun nnvirtual-request-list (&optional server) | |
227 (setq nnvirtual-status-string "nnvirtual: LIST is not implemented.") | |
228 nil) | |
229 | |
230 (defun nnvirtual-request-newgroups (date &optional server) | |
231 "List new groups." | |
232 (setq nnvirtual-status-string "NEWGROUPS is not supported.") | |
233 nil) | |
234 | |
235 (defun nnvirtual-request-list-newsgroups (&optional server) | |
236 (setq nnvirtual-status-string | |
237 "nnvirtual: LIST NEWSGROUPS is not implemented.") | |
238 nil) | |
239 | |
240 (defalias 'nnvirtual-request-post 'nntp-request-post) | |
241 | |
242 (defun nnvirtual-request-post-buffer | |
243 (post group subject header article-buffer info follow-to respect-poster) | |
244 (nntp-request-post-buffer post "" subject header article-buffer | |
245 info follow-to respect-poster)) | |
246 | |
247 | |
248 ;;; Internal functions. | |
249 | |
250 ;; Convert HEAD headers into NOV headers. | |
251 (defun nnvirtual-convert-headers () | |
252 (save-excursion | |
253 (set-buffer nntp-server-buffer) | |
254 (let* ((gnus-newsgroup-dependencies (make-vector 100 0)) | |
255 (headers (gnus-get-newsgroup-headers)) | |
256 header) | |
257 (erase-buffer) | |
258 (while headers | |
259 (setq header (car headers) | |
260 headers (cdr headers)) | |
261 (insert (int-to-string (mail-header-number header)) "\t" | |
262 (or (mail-header-subject header) "") "\t" | |
263 (or (mail-header-from header) "") "\t" | |
264 (or (mail-header-date header) "") "\t" | |
265 (or (mail-header-id header) "") "\t" | |
266 (or (mail-header-references header) "") "\t" | |
267 (int-to-string (or (mail-header-chars header) 0)) "\t" | |
268 (int-to-string (or (mail-header-lines header) 0)) "\t" | |
269 (if (mail-header-xref header) | |
270 (concat "Xref: " (mail-header-xref header) "\t") | |
271 "") "\n"))))) | |
272 | |
273 (defun nnvirtual-possibly-change-newsgroups (group regexp &optional check) | |
274 (let ((inf t)) | |
275 (or (not group) | |
276 (and nnvirtual-current-group | |
277 (string= group nnvirtual-current-group)) | |
278 (and (setq inf (assoc group nnvirtual-group-alist)) | |
279 (string= (nth 3 inf) regexp) | |
280 (progn | |
281 (setq nnvirtual-current-group (car inf)) | |
282 (setq nnvirtual-current-groups (nth 1 inf)) | |
283 (setq nnvirtual-current-mapping (nth 2 inf))))) | |
284 (if (or (not check) (not inf)) | |
285 (progn | |
286 (and inf (setq nnvirtual-group-alist | |
287 (delq inf nnvirtual-group-alist))) | |
288 (setq nnvirtual-current-mapping nil) | |
289 (setq nnvirtual-current-group group) | |
290 (let ((newsrc gnus-newsrc-alist) | |
291 (virt-group (gnus-group-prefixed-name | |
292 nnvirtual-current-group '(nnvirtual "")))) | |
293 (setq nnvirtual-current-groups nil) | |
294 (while newsrc | |
295 (and (string-match regexp (car (car newsrc))) | |
296 (not (string= (car (car newsrc)) virt-group)) | |
297 (setq nnvirtual-current-groups | |
298 (cons (car (car newsrc)) nnvirtual-current-groups))) | |
299 (setq newsrc (cdr newsrc)))) | |
300 (if nnvirtual-current-groups | |
301 (progn | |
302 (nnvirtual-create-mapping group) | |
303 (setq nnvirtual-group-alist | |
304 (cons (list group nnvirtual-current-groups | |
305 nnvirtual-current-mapping regexp) | |
306 nnvirtual-group-alist))) | |
307 (setq nnvirtual-status-string | |
308 (format | |
309 "nnvirtual: No newsgroups for this virtual newsgroup")))))) | |
310 nnvirtual-current-groups) | |
311 | |
312 (defun nnvirtual-create-mapping (group) | |
313 (let* ((group (gnus-group-prefixed-name group (list 'nnvirtual ""))) | |
314 (info (nth 2 (gnus-gethash group gnus-newsrc-hashtb))) | |
315 (groups nnvirtual-current-groups) | |
316 (offset 0) | |
317 reads unread igroup itotal ireads) | |
318 ;; The virtual group doesn't exist. (?) | |
319 (or info (error "No such group: %s" group)) | |
320 (setq nnvirtual-current-mapping nil) | |
321 (while groups | |
322 ;; Added by Sudish Joseph <joseph@cis.ohio-state.edu>. | |
323 (setq igroup (car groups)) | |
324 (let ((info (nth 2 (gnus-gethash igroup gnus-newsrc-hashtb))) | |
325 (active (gnus-gethash igroup gnus-active-hashtb))) | |
326 ;; See if the group has had its active list read this session | |
327 ;; if not, we do it now. | |
328 (if (null active) | |
329 (if (gnus-activate-group igroup) | |
330 (progn | |
331 (gnus-get-unread-articles-in-group | |
332 info (gnus-gethash igroup gnus-active-hashtb)) | |
333 (setq active (gnus-gethash igroup gnus-active-hashtb))) | |
334 (message "Couldn't open component group %s" igroup))) | |
335 (if (null active) | |
336 () | |
337 ;; And then we do the mapping for this component group. If | |
338 ;; you feel tempted to cast your eyes to the soup below - | |
339 ;; don't. It'll hurt your soul. Suffice to say that it | |
340 ;; assigns ranges of nnvirtual article numbers to the | |
341 ;; different component groups. To get the article number | |
342 ;; from the nnvirtual number, one does something like | |
343 ;; (+ (- number offset) (car active)), where `offset' is the | |
344 ;; slice the mess below assigns, and active is the lowest | |
345 ;; active article in the component group. | |
346 (setq itotal (1+ (- (cdr active) (car active)))) | |
347 (if (setq ireads (nth 2 info)) | |
348 (let ((itreads | |
349 (if (not (listp (cdr ireads))) | |
350 (setq ireads (list (cons (car ireads) (cdr ireads)))) | |
351 (setq ireads (copy-alist ireads))))) | |
352 (if (< (or (and (numberp (car ireads)) (car ireads)) | |
353 (cdr (car ireads))) (car active)) | |
354 (setq ireads (setq itreads (cdr ireads)))) | |
355 (if (and ireads (< (or (and (numberp (car ireads)) | |
356 (car ireads)) | |
357 (car (car ireads))) (car active))) | |
358 (setcar (or (and (numberp (car ireads)) ireads) | |
359 (car ireads)) (1+ (car active)))) | |
360 (while itreads | |
361 (setcar (or (and (numberp (car itreads)) itreads) | |
362 (car itreads)) | |
363 (+ (max | |
364 1 (- (if (numberp (car itreads)) | |
365 (car itreads) | |
366 (car (car itreads))) | |
367 (car active))) | |
368 offset)) | |
369 (if (not (numberp (car itreads))) | |
370 (setcdr (car itreads) | |
371 (+ (- (cdr (car itreads)) (car active)) offset))) | |
372 (setq itreads (cdr itreads))) | |
373 (setq reads (nconc reads ireads)))) | |
374 (setq offset (+ offset (1- itotal))) | |
375 (setq nnvirtual-current-mapping | |
376 (cons (list offset igroup (car active)) | |
377 nnvirtual-current-mapping))) | |
378 (setq groups (cdr groups)))) | |
379 (setq nnvirtual-current-mapping | |
380 (nreverse nnvirtual-current-mapping)) | |
381 ;; Set Gnus active info. | |
382 (gnus-sethash group (cons 1 (1- offset)) gnus-active-hashtb) | |
383 ;; Set Gnus read info. | |
384 (setcar (nthcdr 2 info) reads) | |
385 | |
386 ;; Then we deal with the marks. | |
387 (let ((map nnvirtual-current-mapping) | |
388 (marks '(tick dormant reply expire score)) | |
389 (offset 0) | |
390 tick dormant reply expire score marked active) | |
391 (while map | |
392 (setq igroup (nth 1 (car map))) | |
393 (setq active (nth 2 (car map))) | |
394 (setq marked (nth 3 (nth 2 (gnus-gethash igroup gnus-newsrc-hashtb)))) | |
395 (let ((m marks)) | |
396 (while m | |
397 (and (assq (car m) marked) | |
398 (set (car m) | |
399 (nconc (mapcar | |
400 (lambda (art) | |
401 (if (numberp art) | |
402 (if (< art active) | |
403 0 (+ (- art active) offset)) | |
404 (cons (+ (- (car art) active) offset) | |
405 (cdr art)))) | |
406 (cdr (assq (car m) marked))) | |
407 (symbol-value (car m))))) | |
408 (setq m (cdr m)))) | |
409 (setq offset (car (car map))) | |
410 (setq map (cdr map))) | |
411 ;; Put the list of marked articles in the info of the virtual group. | |
412 (let ((m marks) | |
413 marked) | |
414 (while m | |
415 (and (symbol-value (car m)) | |
416 (setq marked (cons (cons (car m) (symbol-value (car m))) | |
417 marked))) | |
418 (setq m (cdr m))) | |
419 (if (nthcdr 3 info) | |
420 (setcar (nthcdr 3 info) marked) | |
421 (setcdr (nthcdr 2 info) (list marked))))))) | |
422 | |
423 (defun nnvirtual-update-marked () | |
424 (let ((mark-lists '((gnus-newsgroup-marked . tick) | |
425 (gnus-newsgroup-dormant . dormant) | |
426 (gnus-newsgroup-expirable . expire) | |
427 (gnus-newsgroup-replied . reply))) | |
428 marks art-group group-alist g) | |
429 (while mark-lists | |
430 (setq marks (symbol-value (car (car mark-lists)))) | |
431 ;; Find out what groups the mark belong to. | |
432 (while marks | |
433 (setq art-group (nnvirtual-art-group (car marks))) | |
434 (if (setq g (assoc (car art-group) group-alist)) | |
435 (nconc g (list (cdr art-group))) | |
436 (setq group-alist (cons (list (car art-group) (cdr art-group)) | |
437 group-alist))) | |
438 (setq marks (cdr marks))) | |
439 ;; The groups that don't have marks must have no marks. (Yup.) | |
440 (let ((groups nnvirtual-current-groups)) | |
441 (while groups | |
442 (or (assoc (car groups) group-alist) | |
443 (setq group-alist (cons (list (car groups)) group-alist))) | |
444 (setq groups (cdr groups)))) | |
445 ;; The we update the list of marks. | |
446 (while group-alist | |
447 (gnus-add-marked-articles | |
448 (car (car group-alist)) (cdr (car mark-lists)) | |
449 (cdr (car group-alist)) nil t) | |
450 (gnus-group-update-group (car (car group-alist)) t) | |
451 (setq group-alist (cdr group-alist))) | |
452 (setq mark-lists (cdr mark-lists))))) | |
453 | |
454 (defun nnvirtual-art-group (article) | |
455 (let ((map nnvirtual-current-mapping) | |
456 (offset 0)) | |
457 (while (< (car (car map)) (if (numberp article) article (car article))) | |
458 (setq offset (car (car map)) | |
459 map (cdr map))) | |
460 (cons (nth 1 (car map)) | |
461 (if (numberp article) | |
462 (- (+ article (nth 2 (car map))) offset) | |
463 (cons (- (+ (car article) (nth 2 (car map))) offset) | |
464 (cdr article)))))) | |
465 | |
466 (defun nnvirtual-catchup-group (group &optional server all) | |
467 (nnvirtual-possibly-change-newsgroups group server) | |
468 (let ((gnus-group-marked nnvirtual-current-groups) | |
469 (gnus-expert-user t)) | |
470 (save-excursion | |
471 (set-buffer gnus-group-buffer) | |
472 (gnus-group-catchup-current nil all)))) | |
473 | |
474 (provide 'nnvirtual) | |
475 | |
476 ;;; nnvirtual.el ends here |