Update copyright year to 2016
[gnus] / lisp / nnvirtual.el
1 ;;; nnvirtual.el --- virtual newsgroups access for Gnus
2
3 ;; Copyright (C) 1994-2016 Free Software Foundation, Inc.
4
5 ;; Author: David Moore <dmoore@ucsd.edu>
6 ;;      Lars Magne Ingebrigtsen <larsi@gnus.org>
7 ;;      Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
8 ;; Keywords: news
9
10 ;; This file is part of GNU Emacs.
11
12 ;; GNU Emacs is free software: you can redistribute it and/or modify
13 ;; it under the terms of the GNU General Public License as published by
14 ;; the Free Software Foundation, either version 3 of the License, or
15 ;; (at your option) any later version.
16
17 ;; GNU Emacs is distributed in the hope that it will be useful,
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
20 ;; GNU General Public License for more details.
21
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
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 (require 'gnus-util)
38 (require 'gnus-start)
39 (require 'gnus-sum)
40 (require 'gnus-msg)
41 (eval-when-compile (require 'cl))
42
43 (nnoo-declare nnvirtual)
44
45 (defvoo nnvirtual-always-rescan t
46   "If non-nil, always scan groups for unread articles when entering a group.
47 If this variable is nil and you read articles in a component group
48 after the virtual group has been activated, the read articles from the
49 component group will show up when you enter the virtual group.")
50
51 (defvoo nnvirtual-component-regexp nil
52   "Regexp to match component groups.")
53
54 (defvoo nnvirtual-component-groups nil
55   "Component group in this nnvirtual group.")
56
57 \f
58
59 (defconst nnvirtual-version "nnvirtual 1.1")
60
61 (defvoo nnvirtual-current-group nil)
62
63 (defvoo nnvirtual-mapping-table nil
64   "Table of rules on how to map between component group and article number to virtual article number.")
65
66 (defvoo nnvirtual-mapping-offsets nil
67   "Table indexed by component group to an offset to be applied to article numbers in that group.")
68
69 (defvoo nnvirtual-mapping-len 0
70   "Number of articles in this virtual group.")
71
72 (defvoo nnvirtual-mapping-reads nil
73   "Compressed sequence of read articles on the virtual group as computed from the unread status of individual component groups.")
74
75 (defvoo nnvirtual-mapping-marks nil
76   "Compressed marks alist for the virtual group as computed from the marks of individual component groups.")
77
78 (defvoo nnvirtual-info-installed nil
79   "T if we have already installed the group info for this group, and shouldn't blast over it again.")
80
81 (defvoo nnvirtual-status-string "")
82
83 (autoload 'gnus-cache-articles-in-group "gnus-cache")
84
85 \f
86
87 ;;; Interface functions.
88
89 (nnoo-define-basics nnvirtual)
90
91
92 (deffoo nnvirtual-retrieve-headers (articles &optional newsgroup
93                                              server fetch-old)
94   (when (nnvirtual-possibly-change-server server)
95     (with-current-buffer nntp-server-buffer
96       (erase-buffer)
97       (if (stringp (car articles))
98           'headers
99         (let ((vbuf (nnheader-set-temp-buffer
100                      (get-buffer-create " *virtual headers*")))
101               (carticles (nnvirtual-partition-sequence articles))
102               (sysname (system-name))
103               cgroup carticle article result prefix)
104           (while carticles
105             (setq cgroup (caar carticles))
106             (setq articles (cdar carticles))
107             (pop carticles)
108             (when (and articles
109                        (gnus-check-server
110                         (gnus-find-method-for-group cgroup) t)
111                        (gnus-request-group cgroup t)
112                        (setq prefix (gnus-group-real-prefix cgroup))
113                        ;; FIX FIX FIX we want to check the cache!
114                        ;; This is probably evil if people have set
115                        ;; gnus-use-cache to nil themselves, but I
116                        ;; have no way of finding the true value of it.
117                        (let ((gnus-use-cache t))
118                          (setq result (gnus-retrieve-headers
119                                        articles cgroup nil))))
120               (set-buffer nntp-server-buffer)
121               ;; If we got HEAD headers, we convert them into NOV
122               ;; headers.  This is slow, inefficient and, come to think
123               ;; of it, downright evil.  So sue me.  I couldn't be
124               ;; bothered to write a header parse routine that could
125               ;; parse a mixed HEAD/NOV buffer.
126               (when (eq result 'headers)
127                 (nnvirtual-convert-headers))
128               (goto-char (point-min))
129               (while (not (eobp))
130                 (delete-region (point)
131                                (progn
132                                  (setq carticle (read nntp-server-buffer))
133                                  (point)))
134
135                 ;; We remove this article from the articles list, if
136                 ;; anything is left in the articles list after going through
137                 ;; the entire buffer, then those articles have been
138                 ;; expired or canceled, so we appropriately update the
139                 ;; component group below.  They should be coming up
140                 ;; generally in order, so this shouldn't be slow.
141                 (setq articles (delq carticle articles))
142
143                 (setq article (nnvirtual-reverse-map-article cgroup carticle))
144                 (if (null article)
145                     ;; This line has no reverse mapping, that means it
146                     ;; was an extra article reference returned by nntp.
147                     (progn
148                       (beginning-of-line)
149                       (delete-region (point) (progn (forward-line 1) (point))))
150                   ;; Otherwise insert the virtual article number,
151                   ;; and clean up the xrefs.
152                   (princ article nntp-server-buffer)
153                   (nnvirtual-update-xref-header cgroup carticle
154                                                 prefix sysname)
155                   (forward-line 1))
156                 )
157
158               (set-buffer vbuf)
159               (goto-char (point-max))
160               (insert-buffer-substring nntp-server-buffer))
161             ;; Anything left in articles is expired or canceled.
162             ;; Could be smart and not tell it about articles already known?
163             (when articles
164               (gnus-group-make-articles-read cgroup articles))
165             )
166
167           ;; The headers are ready for reading, so they are inserted into
168           ;; the nntp-server-buffer, which is where Gnus expects to find
169           ;; them.
170           (prog1
171               (with-current-buffer nntp-server-buffer
172                 (erase-buffer)
173                 (insert-buffer-substring vbuf)
174                 ;; FIX FIX FIX, we should be able to sort faster than
175                 ;; this if needed, since each cgroup is sorted, we just
176                 ;; need to merge
177                 (sort-numeric-fields 1 (point-min) (point-max))
178                 'nov)
179             (kill-buffer vbuf)))))))
180
181
182 (defvoo nnvirtual-last-accessed-component-group nil)
183
184 (deffoo nnvirtual-request-article (article &optional group server buffer)
185   (when (nnvirtual-possibly-change-server server)
186     (if (stringp article)
187         ;; This is a fetch by Message-ID.
188         (cond
189          ((not nnvirtual-last-accessed-component-group)
190           (nnheader-report
191            'nnvirtual "Don't know what server to request from"))
192          (t
193           (save-excursion
194             (when buffer
195               (set-buffer buffer))
196             (let* ((gnus-override-method nil)
197                    (gnus-command-method
198                     (gnus-find-method-for-group
199                      nnvirtual-last-accessed-component-group)))
200               (funcall (gnus-get-function gnus-command-method 'request-article)
201                        article nil (nth 1 gnus-command-method) buffer)))))
202       ;; This is a fetch by number.
203       (let* ((amap (nnvirtual-map-article article))
204              (cgroup (car amap)))
205         (cond
206          ((not amap)
207           (nnheader-report 'nnvirtual "No such article: %s" article))
208          ((not (gnus-check-group cgroup))
209           (nnheader-report
210            'nnvirtual "Can't open server where %s exists" cgroup))
211          ((not (gnus-request-group cgroup t))
212           (nnheader-report 'nnvirtual "Can't open component group %s" cgroup))
213          (t
214           (setq nnvirtual-last-accessed-component-group cgroup)
215           (if buffer
216               (with-current-buffer buffer
217                 ;; We bind this here to avoid double decoding.
218                 (let ((gnus-article-decode-hook nil))
219                   (gnus-request-article-this-buffer (cdr amap) cgroup)))
220             (gnus-request-article (cdr amap) cgroup))))))))
221
222
223 (deffoo nnvirtual-open-server (server &optional defs)
224   (unless (assq 'nnvirtual-component-regexp defs)
225     (push `(nnvirtual-component-regexp ,server)
226           defs))
227   (nnoo-change-server 'nnvirtual server defs)
228   (if nnvirtual-component-groups
229       t
230     (setq nnvirtual-mapping-table nil
231           nnvirtual-mapping-offsets nil
232           nnvirtual-mapping-len 0
233           nnvirtual-mapping-reads nil
234           nnvirtual-mapping-marks nil
235           nnvirtual-info-installed nil)
236     (when nnvirtual-component-regexp
237       ;; Go through the newsrc alist and find all component groups.
238       (let ((newsrc (cdr gnus-newsrc-alist))
239             group)
240         (while (setq group (car (pop newsrc)))
241           (when (string-match nnvirtual-component-regexp group) ; Match
242             ;; Add this group to the list of component groups.
243             (setq nnvirtual-component-groups
244                   (cons group (delete group nnvirtual-component-groups)))))))
245     (if (not nnvirtual-component-groups)
246         (nnheader-report 'nnvirtual "No component groups: %s" server)
247       t)))
248
249
250 (deffoo nnvirtual-request-group (group &optional server dont-check info)
251   (nnvirtual-possibly-change-server server)
252   (setq nnvirtual-component-groups
253         (delete (nnvirtual-current-group) nnvirtual-component-groups))
254   (cond
255    ((null nnvirtual-component-groups)
256     (setq nnvirtual-current-group nil)
257     (nnheader-report 'nnvirtual "No component groups in %s" group))
258    (t
259     (setq nnvirtual-current-group group)
260     (nnvirtual-create-mapping dont-check)
261     (when nnvirtual-always-rescan
262       (nnvirtual-request-update-info
263        (nnvirtual-current-group)
264        (gnus-get-info (nnvirtual-current-group))))
265     (nnheader-insert "211 %d 1 %d %s\n"
266                      nnvirtual-mapping-len nnvirtual-mapping-len group))))
267
268
269 (deffoo nnvirtual-request-type (group &optional article)
270   (if (not article)
271       'unknown
272     (if (numberp article)
273         (let ((mart (nnvirtual-map-article article)))
274           (if mart
275               (gnus-request-type (car mart) (cdr mart))))
276       (gnus-request-type
277        nnvirtual-last-accessed-component-group nil))))
278
279 (deffoo nnvirtual-request-update-mark (group article mark)
280   (let* ((nart (nnvirtual-map-article article))
281          (cgroup (car nart)))
282     (when (and nart
283                (memq mark gnus-auto-expirable-marks)
284                ;; The component group might be a virtual group.
285                (= mark (gnus-request-update-mark cgroup (cdr nart) mark))
286                (gnus-group-auto-expirable-p cgroup))
287       (setq mark gnus-expirable-mark)))
288   mark)
289
290
291 (deffoo nnvirtual-close-group (group &optional server)
292   (when (and (nnvirtual-possibly-change-server server)
293              (not (gnus-ephemeral-group-p (nnvirtual-current-group))))
294     (nnvirtual-update-read-and-marked t t))
295   t)
296
297
298 (deffoo nnvirtual-request-newgroups (date &optional server)
299   (nnheader-report 'nnvirtual "NEWGROUPS is not supported."))
300
301
302 (deffoo nnvirtual-request-list-newsgroups (&optional server)
303   (nnheader-report 'nnvirtual "LIST NEWSGROUPS is not implemented."))
304
305
306 (deffoo nnvirtual-request-update-info (group info &optional server)
307   (when (and (nnvirtual-possibly-change-server server)
308              (not nnvirtual-info-installed))
309     ;; Install the precomputed lists atomically, so the virtual group
310     ;; is not left in a half-way state in case of C-g.
311     (gnus-atomic-progn
312       (setcar (cddr info) nnvirtual-mapping-reads)
313       (if (nthcdr 3 info)
314           (setcar (nthcdr 3 info) nnvirtual-mapping-marks)
315         (when nnvirtual-mapping-marks
316           (setcdr (nthcdr 2 info) (list nnvirtual-mapping-marks))))
317       (setq nnvirtual-info-installed t))
318     t))
319
320
321 (deffoo nnvirtual-catchup-group (group &optional server all)
322   (when (and (nnvirtual-possibly-change-server server)
323              (not (gnus-ephemeral-group-p (nnvirtual-current-group))))
324     ;; copy over existing marks first, in case they set anything
325     (nnvirtual-update-read-and-marked nil nil)
326     ;; do a catchup on all component groups
327     (let ((gnus-group-marked (copy-sequence nnvirtual-component-groups))
328           (gnus-expert-user t))
329       ;; Make sure all groups are activated.
330       (mapc
331        (lambda (g)
332          (when (not (numberp (gnus-group-unread g)))
333            (gnus-activate-group g)))
334        nnvirtual-component-groups)
335       (with-current-buffer gnus-group-buffer
336         (gnus-group-catchup-current nil all)))))
337
338
339 (deffoo nnvirtual-find-group-art (group article)
340   "Return the real group and article for virtual GROUP and ARTICLE."
341   (nnvirtual-map-article article))
342
343
344 (deffoo nnvirtual-request-post (&optional server)
345   (if (not gnus-message-group-art)
346       (nnheader-report 'nnvirtual "Can't post to an nnvirtual group")
347     (let ((group (car (nnvirtual-find-group-art
348                        (car gnus-message-group-art)
349                        (cdr gnus-message-group-art)))))
350       (gnus-request-post (gnus-find-method-for-group group)))))
351
352
353 (deffoo nnvirtual-request-expire-articles (articles group
354                                                     &optional server force)
355   (nnvirtual-possibly-change-server server)
356   (setq nnvirtual-component-groups
357         (delete (nnvirtual-current-group) nnvirtual-component-groups))
358   (let (unexpired)
359     (dolist (group nnvirtual-component-groups)
360       (setq unexpired (nconc unexpired
361                              (mapcar
362                               #'(lambda (article)
363                                   (nnvirtual-reverse-map-article
364                                    group article))
365                               (gnus-uncompress-range
366                                (gnus-group-expire-articles-1 group))))))
367     (sort (delq nil unexpired) '<)))
368
369 \f
370 ;;; Internal functions.
371
372 (defun nnvirtual-convert-headers ()
373   "Convert HEAD headers into NOV headers."
374   (with-current-buffer nntp-server-buffer
375     (let* ((dependencies (make-vector 100 0))
376            (headers (gnus-get-newsgroup-headers dependencies)))
377       (erase-buffer)
378       (mapc 'nnheader-insert-nov headers))))
379
380
381 (defun nnvirtual-update-xref-header (group article prefix sysname)
382   "Edit current NOV header in current buffer to have an xref to the component group, and also server prefix any existing xref lines."
383   ;; Move to beginning of Xref field, creating a slot if needed.
384   (beginning-of-line)
385   (looking-at
386    "[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t")
387   (goto-char (match-end 0))
388   (unless (search-forward "\t" (point-at-eol) 'move)
389     (insert "\t"))
390
391   ;; Remove any spaces at the beginning of the Xref field.
392   (while (eq (char-after (1- (point))) ? )
393     (forward-char -1)
394     (delete-char 1))
395
396   (insert "Xref: " sysname " " group ":")
397   (princ article (current-buffer))
398   (insert " ")
399
400   ;; If there were existing xref lines, clean them up to have the correct
401   ;; component server prefix.
402   (save-restriction
403     (narrow-to-region (point)
404                       (or (search-forward "\t" (point-at-eol) t)
405                           (point-at-eol)))
406     (goto-char (point-min))
407     (when (re-search-forward "Xref: *[^\n:0-9 ]+ *" nil t)
408       (replace-match "" t t))
409     (goto-char (point-min))
410     (when (re-search-forward
411            (concat (regexp-quote (gnus-group-real-name group)) ":[0-9]+")
412            nil t)
413       (replace-match "" t t))
414     (unless (eobp)
415       (insert " ")
416       (when (not (string= "" prefix))
417         (while (re-search-forward "[^ ]+:[0-9]+" nil t)
418           (save-excursion
419             (goto-char (match-beginning 0))
420             (insert prefix))))))
421
422   ;; Ensure a trailing \t.
423   (end-of-line)
424   (or (eq (char-after (1- (point))) ?\t)
425       (insert ?\t)))
426
427
428 (defun nnvirtual-possibly-change-server (server)
429   (or (not server)
430       (nnoo-current-server-p 'nnvirtual server)
431       (nnvirtual-open-server server)))
432
433
434 (defun nnvirtual-update-read-and-marked (read-p update-p)
435   "Copy marks from the virtual group to the component groups.
436 If READ-P is not nil, update the (un)read status of the components.
437 If UPDATE-P is not nil, call gnus-group-update-group on the components."
438   (when nnvirtual-current-group
439     (let ((unreads (and read-p
440                         (nnvirtual-partition-sequence
441                          (gnus-list-of-unread-articles
442                           (nnvirtual-current-group)))))
443           (type-marks
444            (delq nil
445                  (mapcar (lambda (ml)
446                            (if (eq (car ml) 'score)
447                                nil
448                              (cons (car ml)
449                                    (nnvirtual-partition-sequence (cdr ml)))))
450                          (gnus-info-marks (gnus-get-info
451                                            (nnvirtual-current-group))))))
452           type groups info)
453
454       ;; Ok, atomically move all of the (un)read info, clear any old
455       ;; marks, and move all of the current marks.  This way if someone
456       ;; hits C-g, you won't leave the component groups in a half-way state.
457       (progn
458         ;; move (un)read
459         ;; bind for workaround guns-update-read-articles
460         (let ((gnus-newsgroup-active nil))
461           (dolist (entry unreads)
462             (gnus-update-read-articles (car entry) (cdr entry))))
463
464         ;; clear all existing marks on the component groups
465         (dolist (group nnvirtual-component-groups)
466           (when (and (setq info (gnus-get-info group))
467                      (gnus-info-marks info))
468             (gnus-info-set-marks
469              info
470              (if (assq 'score (gnus-info-marks info))
471                  (list (assq 'score (gnus-info-marks info)))
472                nil))))
473
474         ;; Ok, currently type-marks is an assq list with keys of a mark type,
475         ;; with data of an assq list with keys of component group names
476         ;; and the articles which correspond to that key/group pair.
477         (dolist (mark type-marks)
478           (setq type (car mark))
479           (setq groups (cdr mark))
480           (dolist (carticles groups)
481             (gnus-add-marked-articles (car carticles) type (cdr carticles)
482                                       nil t))))
483
484       ;; possibly update the display, it is really slow
485       (when update-p
486         (dolist (group nnvirtual-component-groups)
487           (gnus-group-update-group group t))))))
488
489
490 (defun nnvirtual-current-group ()
491   "Return the prefixed name of the current nnvirtual group."
492   (concat "nnvirtual:" nnvirtual-current-group))
493
494
495
496 ;;; This is currently O(kn^2) to merge n lists of length k.
497 ;;; You could do it in O(knlogn), but we have a small n, and the
498 ;;; overhead of the other approach is probably greater.
499 (defun nnvirtual-merge-sorted-lists (&rest lists)
500   "Merge many sorted lists of numbers."
501   (if (null (cdr lists))
502       (car lists)
503     (sort (apply 'nconc lists) '<)))
504
505
506 ;;; We map between virtual articles and real articles in a manner
507 ;;; which keeps the size of the virtual active list the same as the
508 ;;; sum of the component active lists.
509
510 ;;; To achieve fair mixing of the groups, the last article in each of
511 ;;; N component groups will be in the last N articles in the virtual
512 ;;; group.
513
514 ;;; If you have 3 components A, B and C, with articles 1-8, 1-5, and
515 ;;; 6-7 respectively, then the virtual article numbers look like:
516 ;;;
517 ;;;  1  2  3  4  5  6  7  8  9  10 11 12 13 14 15
518 ;;;  A1 A2 A3 A4 B1 A5 B2 A6 B3 A7 B4 C6 A8 B5 C7
519
520 ;;; To compute these mappings we generate a couple tables and then
521 ;;; do some fast operations on them.  Tables for the example above:
522 ;;;
523 ;;; Offsets - [(A 0) (B -3) (C -1)]
524 ;;;
525 ;;;               a  b  c  d  e
526 ;;; Mapping - ([  3  0  1  3  0 ]
527 ;;;            [  6  3  2  9  3 ]
528 ;;;            [  8  6  3 15  9 ])
529 ;;;
530 ;;; (note column 'e' is different in real algorithm, which is slightly
531 ;;;  different than described here, but this gives you the methodology.)
532 ;;;
533 ;;; The basic idea is this, when going from component->virtual, apply
534 ;;; the appropriate offset to the article number.  Then search the first
535 ;;; column of the table for a row where 'a' is less than or equal to the
536 ;;; modified number.  You can see that only group A can therefore go to
537 ;;; the first row, groups A and B to the second, and all to the last.
538 ;;; The third column of the table is telling us the number of groups
539 ;;; which might be able to reach that row (it might increase by more than
540 ;;; 1 if several groups have the same size).
541 ;;; Then column 'b' provides an additional offset you apply when you have
542 ;;; found the correct row.  You then multiply by 'c' and add on the groups
543 ;;; _position_ in the offset table.  The basic idea here is that on
544 ;;; any given row we are going to map back and forth using X'=X*c+Y and
545 ;;; X=(X'/c), Y=(X' mod c).  Then once you've done this transformation,
546 ;;; you apply a final offset from column 'e' to give the virtual article.
547 ;;;
548 ;;; Going the other direction, you instead search on column 'd' instead
549 ;;; of 'a', and apply everything in reverse order.
550
551 ;;; Convert component -> virtual:
552 ;;; set num = num - Offset(group)
553 ;;; find first row in Mapping where num <= 'a'
554 ;;; num = (num-'b')*c + Position(group) + 'e'
555
556 ;;; Convert virtual -> component:
557 ;;; find first row in Mapping where num <= 'd'
558 ;;; num = num - 'e'
559 ;;; group_pos = num mod 'c'
560 ;;; num = (num / 'c') + 'b' + Offset(group_pos)
561
562 ;;; Easy no? :)
563 ;;;
564 ;;; Well actually, you need to keep column e offset smaller by the 'c'
565 ;;; column for that line, and always add 1 more when going from
566 ;;; component -> virtual.  Otherwise you run into a problem with
567 ;;; unique reverse mapping.
568
569 (defun nnvirtual-map-article (article)
570   "Return a cons of the component group and article corresponding to the given virtual ARTICLE."
571   (let ((table nnvirtual-mapping-table)
572         entry group-pos)
573     (while (and table
574                 (> article (aref (car table) 3)))
575       (setq table (cdr table)))
576     (when (and table
577                (> article 0))
578       (setq entry (car table))
579       (setq article (- article (aref entry 4) 1))
580       (setq group-pos (mod article (aref entry 2)))
581       (cons (car (aref nnvirtual-mapping-offsets group-pos))
582             (+ (/ article (aref entry 2))
583                (aref entry 1)
584                (cdr (aref nnvirtual-mapping-offsets group-pos)))
585             ))
586     ))
587
588
589
590 (defun nnvirtual-reverse-map-article (group article)
591   "Return the virtual article number corresponding to the given component GROUP and ARTICLE."
592   (when (numberp article)
593     (let ((table nnvirtual-mapping-table)
594           (group-pos 0)
595           entry)
596       (while (not (string= group (car (aref nnvirtual-mapping-offsets
597                                             group-pos))))
598         (setq group-pos (1+ group-pos)))
599       (setq article (- article (cdr (aref nnvirtual-mapping-offsets
600                                           group-pos))))
601       (while (and table
602                   (> article (aref (car table) 0)))
603         (setq table (cdr table)))
604       (setq entry (car table))
605       (when (and entry
606                  (> article 0)
607                  (< group-pos (aref entry 2))) ; article not out of range below
608         (+ (aref entry 4)
609            group-pos
610            (* (- article (aref entry 1))
611               (aref entry 2))
612            1))
613       )))
614
615
616 (defsubst nnvirtual-reverse-map-sequence (group articles)
617   "Return list of virtual article numbers for all ARTICLES in GROUP.
618 The ARTICLES should be sorted, and can be a compressed sequence.
619 If any of the article numbers has no corresponding virtual article,
620 then it is left out of the result."
621   (when (numberp (cdr-safe articles))
622     (setq articles (list articles)))
623   (let (result a i j new-a)
624     (while (setq a (pop articles))
625       (if (atom a)
626           (setq i a
627                 j a)
628         (setq i (car a)
629               j (cdr a)))
630       (while (<= i j)
631         ;; If this is slow, you can optimize by moving article checking
632         ;; into here.  You don't have to recompute the group-pos,
633         ;; nor scan the table every time.
634         (when (setq new-a (nnvirtual-reverse-map-article group i))
635           (push new-a result))
636         (setq i (1+ i))))
637     (nreverse result)))
638
639
640 (defun nnvirtual-partition-sequence (articles)
641   "Return an association list of component article numbers.
642 These are indexed by elements of nnvirtual-component-groups, based on
643 the sequence ARTICLES of virtual article numbers.  ARTICLES should be
644 sorted, and can be a compressed sequence.  If any of the article
645 numbers has no corresponding component article, then it is left out of
646 the result."
647   (when (numberp (cdr-safe articles))
648     (setq articles (list articles)))
649   (let ((carticles (mapcar 'list nnvirtual-component-groups))
650         a i j article entry)
651     (while (setq a (pop articles))
652       (if (atom a)
653           (setq i a
654                 j a)
655         (setq i (car a)
656               j (cdr a)))
657       (while (<= i j)
658         (when (setq article (nnvirtual-map-article i))
659           (setq entry (assoc (car article) carticles))
660           (setcdr entry (cons (cdr article) (cdr entry))))
661         (setq i (1+ i))))
662     (mapc (lambda (x) (setcdr x (nreverse (cdr x))))
663           carticles)
664     carticles))
665
666
667 (defun nnvirtual-create-mapping (dont-check)
668   "Build the tables necessary to map between component (group, article) to virtual article.
669 Generate the set of read messages and marks for the virtual group
670 based on the marks on the component groups."
671   (let ((cnt 0)
672         (tot 0)
673         (M 0)
674         (i 0)
675         actives all-unreads all-marks
676         active min max size unreads marks
677         next-M next-tot
678         reads beg)
679     ;; Ok, we loop over all component groups and collect a lot of
680     ;; information:
681     ;; Into actives we place (g size max), where size is max-min+1.
682     ;; Into all-unreads we put (g unreads).
683     ;; Into all-marks we put (g marks).
684     ;; We also increment cnt and tot here, and compute M (max of sizes).
685     (mapc (lambda (g)
686             (setq active (or (and dont-check
687                                   (gnus-active g))
688                              (gnus-activate-group g))
689                   min (car active)
690                   max (cdr active))
691             (when (and active (>= max min) (not (zerop max)))
692               ;; store active information
693               (push (list g (- max min -1) max) actives)
694               ;; collect unread/mark info for later
695               (setq unreads (gnus-list-of-unread-articles g))
696               (setq marks (gnus-info-marks (gnus-get-info g)))
697               (when gnus-use-cache
698                 (push (cons 'cache
699                             (gnus-cache-articles-in-group g))
700                       marks))
701               (push (cons g unreads) all-unreads)
702               (push (cons g marks) all-marks)
703               ;; count groups, total #articles, and max size
704               (setq size (- max min -1))
705               (setq cnt (1+ cnt)
706                     tot (+ tot size)
707                     M (max M size))))
708           nnvirtual-component-groups)
709
710     ;; Number of articles in the virtual group.
711     (setq nnvirtual-mapping-len tot)
712
713
714     ;; We want the actives list sorted by size, to build the tables.
715     (setq actives (sort actives (lambda (g1 g2) (< (nth 1 g1) (nth 1 g2)))))
716
717     ;; Build the offset table.  Largest sized groups are at the front.
718     (setq nnvirtual-mapping-offsets
719           (vconcat
720            (nreverse
721             (mapcar (lambda (entry)
722                       (cons (nth 0 entry)
723                             (- (nth 2 entry) M)))
724                     actives))))
725
726     ;; Build the mapping table.
727     (setq nnvirtual-mapping-table nil)
728     (setq actives (mapcar (lambda (entry) (nth 1 entry)) actives))
729     (while actives
730       (setq size (car actives))
731       (setq next-M (- M size))
732       (setq next-tot (- tot (* cnt size)))
733       ;; make current row in table
734       (push (vector M next-M cnt tot (- next-tot cnt))
735             nnvirtual-mapping-table)
736       ;; update M and tot
737       (setq M next-M)
738       (setq tot next-tot)
739       ;; subtract the current size from all entries.
740       (setq actives (mapcar (lambda (x) (- x size)) actives))
741       ;; remove anything that went to 0.
742       (while (and actives
743                   (= (car actives) 0))
744         (pop actives)
745         (setq cnt (- cnt 1))))
746
747
748     ;; Now that the mapping tables are generated, we can convert
749     ;; and combine the separate component unreads and marks lists
750     ;; into single lists of virtual article numbers.
751     (setq unreads (apply 'nnvirtual-merge-sorted-lists
752                          (mapcar (lambda (x)
753                                    (nnvirtual-reverse-map-sequence
754                                     (car x) (cdr x)))
755                                  all-unreads)))
756     (setq marks (mapcar
757                  (lambda (type)
758                    (cons (cdr type)
759                          (gnus-compress-sequence
760                           (apply
761                            'nnvirtual-merge-sorted-lists
762                            (mapcar (lambda (x)
763                                      (nnvirtual-reverse-map-sequence
764                                       (car x)
765                                       (cdr (assq (cdr type) (cdr x)))))
766                                    all-marks)))))
767                  gnus-article-mark-lists))
768
769     ;; Remove any empty marks lists, and store.
770     (setq nnvirtual-mapping-marks nil)
771     (dolist (mark marks)
772       (when (cdr mark)
773         (push mark nnvirtual-mapping-marks)))
774
775     ;; We need to convert the unreads to reads.  We compress the
776     ;; sequence as we go, otherwise it could be huge.
777     (while (and (<= (incf i) nnvirtual-mapping-len)
778                 unreads)
779       (if (= i (car unreads))
780           (setq unreads (cdr unreads))
781         ;; try to get a range.
782         (setq beg i)
783         (while (and (<= (incf i) nnvirtual-mapping-len)
784                     (not (= i (car unreads)))))
785         (setq i (- i 1))
786         (if (= i beg)
787             (push i reads)
788           (push (cons beg i) reads))
789         ))
790     (when (<= i nnvirtual-mapping-len)
791       (if (= i nnvirtual-mapping-len)
792           (push i reads)
793         (push (cons i nnvirtual-mapping-len) reads)))
794
795     ;; Store the reads list for later use.
796     (setq nnvirtual-mapping-reads (nreverse reads))
797
798     ;; Throw flag to show we changed the info.
799     (setq nnvirtual-info-installed nil)
800     ))
801
802 (provide 'nnvirtual)
803
804 ;;; nnvirtual.el ends here