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