Mercurial > emacs

comparison lisp/nnvirtual.el @ 15511:530d0d516a42

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
New version.
author Lars Magne Ingebrigtsen <larsi@gnus.org>
date Tue, 25 Jun 1996 22:21:39 +0000
parents 83f275dcd93a
children
comparison
equal deleted inserted replaced
15510:db0f45c7f885 15511:530d0d516a42
1 ;;; nnvirtual.el --- virtual newsgroups access for Gnus 1 ;;; nnvirtual.el --- virtual newsgroups access for Gnus
2 2 ;; Copyright (C) 1994,95,96 Free Software Foundation, Inc.
3 ;; Copyright (C) 1994,95 Free Software Foundation, Inc.
4 3
5 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 4 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
6 ;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> 5 ;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
7 ;; Keywords: news 6 ;; Keywords: news
8 7
32 ;;; Code: 31 ;;; Code:
33 32
34 (require 'nntp) 33 (require 'nntp)
35 (require 'nnheader) 34 (require 'nnheader)
36 (require 'gnus) 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.")
37 50
38 51
39 52
40 (defconst nnvirtual-version "nnvirtual 1.0" 53 (defconst nnvirtual-version "nnvirtual 1.0")
41 "Version number of this version of nnvirtual.") 54
42 55 (defvoo nnvirtual-current-group nil)
43 (defvar nnvirtual-group-alist nil) 56 (defvoo nnvirtual-component-groups nil)
44 (defvar nnvirtual-current-group nil) 57 (defvoo nnvirtual-mapping nil)
45 (defvar nnvirtual-current-groups nil) 58
46 (defvar nnvirtual-current-mapping nil) 59 (defvoo nnvirtual-status-string "")
47 60
48 (defvar nnvirtual-do-not-open nil) 61 (eval-and-compile
49 62 (autoload 'gnus-cache-articles-in-group "gnus-cache"))
50 (defvar nnvirtual-status-string "")
51 63
52 64
53 65
54 ;;; Interface functions. 66 ;;; Interface functions.
55 67
56 (defun nnvirtual-retrieve-headers (sequence &optional newsgroup server) 68 (nnoo-define-basics nnvirtual)
57 "Retrieve the headers for the articles in SEQUENCE." 69
58 (nnvirtual-possibly-change-newsgroups newsgroup server t) 70 (deffoo nnvirtual-retrieve-headers (articles &optional newsgroup
59 (save-excursion 71 server fetch-old)
60 (set-buffer (get-buffer-create "*virtual headers*")) 72 (when (nnvirtual-possibly-change-server server)
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 73 (save-excursion
204 (set-buffer nntp-server-buffer) 74 (set-buffer nntp-server-buffer)
205 (erase-buffer) 75 (erase-buffer)
206 (if map 76 (if (stringp (car articles))
207 (progn 77 'headers
208 (while (cdr map) 78 (let ((vbuf (nnheader-set-temp-buffer
209 (setq map (cdr map))) 79 (get-buffer-create " *virtual headers*")))
210 (insert (format "211 %d 1 %d %s\n" (car (car map)) 80 (unfetched (mapcar (lambda (g) (list g))
211 (car (car map)) group)) 81 nnvirtual-component-groups))
212 t) 82 (system-name (system-name))
213 (setq nnvirtual-status-string "No component groups") 83 cgroup article result prefix)
214 (setq nnvirtual-current-group nil) 84 (while articles
215 nil)))) 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)
216 236
217 (defun nnvirtual-close-group (group &optional server) 237 (deffoo nnvirtual-close-group (group &optional server)
218 (if (not nnvirtual-current-group) 238 (when (nnvirtual-possibly-change-server server)
219 () 239 ;; Copy (un)read articles.
220 (nnvirtual-possibly-change-newsgroups group server t) 240 (nnvirtual-update-reads)
221 (nnvirtual-update-marked) 241 ;; We copy the marks from this group to the component
222 (setq nnvirtual-current-group nil 242 ;; groups here.
223 nnvirtual-current-groups nil 243 (nnvirtual-update-marked))
224 nnvirtual-current-mapping nil) 244 t)
225 (setq nnvirtual-group-alist 245
226 (delq (assoc group nnvirtual-group-alist) nnvirtual-group-alist)))) 246 (deffoo nnvirtual-request-list (&optional server)
227 247 (nnheader-report 'nnvirtual "LIST is not implemented."))
228 (defun nnvirtual-request-list (&optional server) 248
229 (setq nnvirtual-status-string "nnvirtual: LIST is not implemented.") 249 (deffoo nnvirtual-request-newgroups (date &optional server)
230 nil) 250 (nnheader-report 'nnvirtual "NEWGROUPS is not supported."))
231 251
232 (defun nnvirtual-request-newgroups (date &optional server) 252 (deffoo nnvirtual-request-list-newsgroups (&optional server)
233 "List new groups." 253 (nnheader-report 'nnvirtual "LIST NEWSGROUPS is not implemented."))
234 (setq nnvirtual-status-string "NEWGROUPS is not supported.") 254
235 nil) 255 (deffoo nnvirtual-request-update-info (group info &optional server)
236 256 (when (nnvirtual-possibly-change-server server)
237 (defun nnvirtual-request-list-newsgroups (&optional server) 257 (let ((map nnvirtual-mapping)
238 (setq nnvirtual-status-string 258 (marks (mapcar (lambda (m) (list (cdr m))) gnus-article-mark-lists))
239 "nnvirtual: LIST NEWSGROUPS is not implemented.") 259 reads mr m op)
240 nil) 260 ;; Go through the mapping.
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
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 261 (while map
394 (setq igroup (nth 1 (car map))) 262 (unless (nth 3 (setq m (pop map)))
395 (setq active (nth 2 (car map))) 263 ;; Read article.
396 (setq marked (nth 3 (nth 2 (gnus-gethash igroup gnus-newsrc-hashtb)))) 264 (push (car m) reads))
397 (let ((m marks)) 265 ;; Copy marks.
398 (while m 266 (when (setq mr (nth 4 m))
399 (and (assq (car m) marked) 267 (while mr
400 (set (car m) 268 (setcdr (setq op (assq (pop mr) marks)) (cons (car m) (cdr op))))))
401 (nconc (mapcar 269 ;; Compress the marks and the reads.
402 (lambda (art) 270 (setq mr marks)
403 (if (numberp art) 271 (while mr
404 (if (< art active) 272 (setcdr (car mr) (gnus-compress-sequence (sort (cdr (pop mr)) '<))))
405 0 (+ (- art active) offset)) 273 (setcar (cddr info) (gnus-compress-sequence (nreverse reads)))
406 (cons (+ (- (car art) active) offset) 274 ;; Remove empty marks lists.
407 (cdr art)))) 275 (while (and marks (not (cdar marks)))
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))) 276 (setq marks (cdr marks)))
441 ;; The groups that don't have marks must have no marks. (Yup.) 277 (setq mr marks)
442 (let ((groups nnvirtual-current-groups)) 278 (while (cdr mr)
443 (while groups 279 (if (cdadr mr)
444 (or (assoc (car groups) group-alist) 280 (setq mr (cdr mr))
445 (setq group-alist (cons (list (car groups)) group-alist))) 281 (setcdr mr (cddr mr))))
446 (setq groups (cdr groups)))) 282
447 ;; The we update the list of marks. 283 ;; Enter these new marks into the info of the group.
448 (while group-alist 284 (if (nthcdr 3 info)
449 (gnus-add-marked-articles 285 (setcar (nthcdr 3 info) marks)
450 (car (car group-alist)) (cdr (car mark-lists)) 286 ;; Add the marks lists to the end of the info.
451 (cdr (car group-alist)) nil t) 287 (when marks
452 (gnus-group-update-group (car (car group-alist)) t) 288 (setcdr (nthcdr 2 info) (list marks))))
453 (setq group-alist (cdr group-alist))) 289 t)))
454 (setq mark-lists (cdr mark-lists))))) 290
455 291 (deffoo nnvirtual-catchup-group (group &optional server all)
456 (defun nnvirtual-art-group (article) 292 (nnvirtual-possibly-change-server server)
457 (let ((map nnvirtual-current-mapping) 293 (let ((gnus-group-marked (copy-sequence nnvirtual-component-groups))
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)) 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)
472 (save-excursion 301 (save-excursion
473 (set-buffer gnus-group-buffer) 302 (set-buffer gnus-group-buffer)
474 (gnus-group-catchup-current nil all)))) 303 (gnus-group-catchup-current nil all))))
475 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
476 (provide 'nnvirtual) 407 (provide 'nnvirtual)
477 408
478 ;;; nnvirtual.el ends here 409 ;;; nnvirtual.el ends here