cgit.sxemacs.org Git - gnus/blob - lisp/nnvirtual.el

   1 ;;; nnvirtual.el --- virtual newsgroups access for Gnus
   2
   3 ;; Copyright (C) 1994-2011 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               (system-name (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 system-name)
 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                    (method (gnus-find-method-for-group
 198                             nnvirtual-last-accessed-component-group)))
 199               (funcall (gnus-get-function method 'request-article)
 200                        article nil (nth 1 method) buffer)))))
 201       ;; This is a fetch by number.
 202       (let* ((amap (nnvirtual-map-article article))
 203              (cgroup (car amap)))
 204         (cond
 205          ((not amap)
 206           (nnheader-report 'nnvirtual "No such article: %s" article))
 207          ((not (gnus-check-group cgroup))
 208           (nnheader-report
 209            'nnvirtual "Can't open server where %s exists" cgroup))
 210          ((not (gnus-request-group cgroup t))
 211           (nnheader-report 'nnvirtual "Can't open component group %s" cgroup))
 212          (t
 213           (setq nnvirtual-last-accessed-component-group cgroup)
 214           (if buffer
 215               (with-current-buffer buffer
 216                 ;; We bind this here to avoid double decoding.
 217                 (let ((gnus-article-decode-hook nil))
 218                   (gnus-request-article-this-buffer (cdr amap) cgroup)))
 219             (gnus-request-article (cdr amap) cgroup))))))))
 220
 221
 222 (deffoo nnvirtual-open-server (server &optional defs)
 223   (unless (assq 'nnvirtual-component-regexp defs)
 224     (push `(nnvirtual-component-regexp ,server)
 225           defs))
 226   (nnoo-change-server 'nnvirtual server defs)
 227   (if nnvirtual-component-groups
 228       t
 229     (setq nnvirtual-mapping-table nil
 230           nnvirtual-mapping-offsets nil
 231           nnvirtual-mapping-len 0
 232           nnvirtual-mapping-reads nil
 233           nnvirtual-mapping-marks nil
 234           nnvirtual-info-installed nil)
 235     (when nnvirtual-component-regexp
 236       ;; Go through the newsrc alist and find all component groups.
 237       (let ((newsrc (cdr gnus-newsrc-alist))
 238             group)
 239         (while (setq group (car (pop newsrc)))
 240           (when (string-match nnvirtual-component-regexp group) ; Match
 241             ;; Add this group to the list of component groups.
 242             (setq nnvirtual-component-groups
 243                   (cons group (delete group nnvirtual-component-groups)))))))
 244     (if (not nnvirtual-component-groups)
 245         (nnheader-report 'nnvirtual "No component groups: %s" server)
 246       t)))
 247
 248
 249 (deffoo nnvirtual-request-group (group &optional server dont-check info)
 250   (nnvirtual-possibly-change-server server)
 251   (setq nnvirtual-component-groups
 252         (delete (nnvirtual-current-group) nnvirtual-component-groups))
 253   (cond
 254    ((null nnvirtual-component-groups)
 255     (setq nnvirtual-current-group nil)
 256     (nnheader-report 'nnvirtual "No component groups in %s" group))
 257    (t
 258     (setq nnvirtual-current-group group)
 259     (nnvirtual-create-mapping dont-check)
 260     (when nnvirtual-always-rescan
 261       (nnvirtual-request-update-info
 262        (nnvirtual-current-group)
 263        (gnus-get-info (nnvirtual-current-group))))
 264     (nnheader-insert "211 %d 1 %d %s\n"
 265                      nnvirtual-mapping-len nnvirtual-mapping-len group))))
 266
 267
 268 (deffoo nnvirtual-request-type (group &optional article)
 269   (if (not article)
 270       'unknown
 271     (if (numberp article)
 272         (let ((mart (nnvirtual-map-article article)))
 273           (if mart
 274               (gnus-request-type (car mart) (cdr mart))))
 275       (gnus-request-type
 276        nnvirtual-last-accessed-component-group nil))))
 277
 278 (deffoo nnvirtual-request-update-mark (group article mark)
 279   (let* ((nart (nnvirtual-map-article article))
 280          (cgroup (car nart)))
 281     (when (and nart
 282                (memq mark gnus-auto-expirable-marks)
 283                ;; The component group might be a virtual group.
 284                (= mark (gnus-request-update-mark cgroup (cdr nart) mark))
 285                (gnus-group-auto-expirable-p cgroup))
 286       (setq mark gnus-expirable-mark)))
 287   mark)
 288
 289
 290 (deffoo nnvirtual-close-group (group &optional server)
 291   (when (and (nnvirtual-possibly-change-server server)
 292              (not (gnus-ephemeral-group-p (nnvirtual-current-group))))
 293     (nnvirtual-update-read-and-marked t t))
 294   t)
 295
 296
 297 (deffoo nnvirtual-request-newgroups (date &optional server)
 298   (nnheader-report 'nnvirtual "NEWGROUPS is not supported."))
 299
 300
 301 (deffoo nnvirtual-request-list-newsgroups (&optional server)
 302   (nnheader-report 'nnvirtual "LIST NEWSGROUPS is not implemented."))
 303
 304
 305 (deffoo nnvirtual-request-update-info (group info &optional server)
 306   (when (and (nnvirtual-possibly-change-server server)
 307              (not nnvirtual-info-installed))
 308     ;; Install the precomputed lists atomically, so the virtual group
 309     ;; is not left in a half-way state in case of C-g.
 310     (gnus-atomic-progn
 311       (setcar (cddr info) nnvirtual-mapping-reads)
 312       (if (nthcdr 3 info)
 313           (setcar (nthcdr 3 info) nnvirtual-mapping-marks)
 314         (when nnvirtual-mapping-marks
 315           (setcdr (nthcdr 2 info) (list nnvirtual-mapping-marks))))
 316       (setq nnvirtual-info-installed t))
 317     t))
 318
 319
 320 (deffoo nnvirtual-catchup-group (group &optional server all)
 321   (when (and (nnvirtual-possibly-change-server server)
 322              (not (gnus-ephemeral-group-p (nnvirtual-current-group))))
 323     ;; copy over existing marks first, in case they set anything
 324     (nnvirtual-update-read-and-marked nil nil)
 325     ;; do a catchup on all component groups
 326     (let ((gnus-group-marked (copy-sequence nnvirtual-component-groups))
 327           (gnus-expert-user t))
 328       ;; Make sure all groups are activated.
 329       (mapc
 330        (lambda (g)
 331          (when (not (numberp (gnus-group-unread g)))
 332            (gnus-activate-group g)))
 333        nnvirtual-component-groups)
 334       (with-current-buffer gnus-group-buffer
 335         (gnus-group-catchup-current nil all)))))
 336
 337
 338 (deffoo nnvirtual-find-group-art (group article)
 339   "Return the real group and article for virtual GROUP and ARTICLE."
 340   (nnvirtual-map-article article))
 341
 342
 343 (deffoo nnvirtual-request-post (&optional server)
 344   (if (not gnus-message-group-art)
 345       (nnheader-report 'nnvirtual "Can't post to an nnvirtual group")
 346     (let ((group (car (nnvirtual-find-group-art
 347                        (car gnus-message-group-art)
 348                        (cdr gnus-message-group-art)))))
 349       (gnus-request-post (gnus-find-method-for-group group)))))
 350
 351
 352 (deffoo nnvirtual-request-expire-articles (articles group
 353                                                     &optional server force)
 354   (nnvirtual-possibly-change-server server)
 355   (setq nnvirtual-component-groups
 356         (delete (nnvirtual-current-group) nnvirtual-component-groups))
 357   (let (unexpired)
 358     (dolist (group nnvirtual-component-groups)
 359       (setq unexpired (nconc unexpired
 360                              (mapcar
 361                               #'(lambda (article)
 362                                   (nnvirtual-reverse-map-article
 363                                    group article))
 364                               (gnus-uncompress-range
 365                                (gnus-group-expire-articles-1 group))))))
 366     (sort (delq nil unexpired) '<)))
 367
 368 \f
 369 ;;; Internal functions.
 370
 371 (defun nnvirtual-convert-headers ()
 372   "Convert HEAD headers into NOV headers."
 373   (with-current-buffer nntp-server-buffer
 374     (let* ((dependencies (make-vector 100 0))
 375            (headers (gnus-get-newsgroup-headers dependencies)))
 376       (erase-buffer)
 377       (mapc 'nnheader-insert-nov headers))))
 378
 379
 380 (defun nnvirtual-update-xref-header (group article prefix system-name)
 381   "Edit current NOV header in current buffer to have an xref to the component group, and also server prefix any existing xref lines."
 382   ;; Move to beginning of Xref field, creating a slot if needed.
 383   (beginning-of-line)
 384   (looking-at
 385    "[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t")
 386   (goto-char (match-end 0))
 387   (unless (search-forward "\t" (point-at-eol) 'move)
 388     (insert "\t"))
 389
 390   ;; Remove any spaces at the beginning of the Xref field.
 391   (while (eq (char-after (1- (point))) ? )
 392     (forward-char -1)
 393     (delete-char 1))
 394
 395   (insert "Xref: " system-name " " group ":")
 396   (princ article (current-buffer))
 397   (insert " ")
 398
 399   ;; If there were existing xref lines, clean them up to have the correct
 400   ;; component server prefix.
 401   (save-restriction
 402     (narrow-to-region (point)
 403                       (or (search-forward "\t" (point-at-eol) t)
 404                           (point-at-eol)))
 405     (goto-char (point-min))
 406     (when (re-search-forward "Xref: *[^\n:0-9 ]+ *" nil t)
 407       (replace-match "" t t))
 408     (goto-char (point-min))
 409     (when (re-search-forward
 410            (concat (regexp-quote (gnus-group-real-name group)) ":[0-9]+")
 411            nil t)
 412       (replace-match "" t t))
 413     (unless (eobp)
 414       (insert " ")
 415       (when (not (string= "" prefix))
 416         (while (re-search-forward "[^ ]+:[0-9]+" nil t)
 417           (save-excursion
 418             (goto-char (match-beginning 0))
 419             (insert prefix))))))
 420
 421   ;; Ensure a trailing \t.
 422   (end-of-line)
 423   (or (eq (char-after (1- (point))) ?\t)
 424       (insert ?\t)))
 425
 426
 427 (defun nnvirtual-possibly-change-server (server)
 428   (or (not server)
 429       (nnoo-current-server-p 'nnvirtual server)
 430       (nnvirtual-open-server server)))
 431
 432
 433 (defun nnvirtual-update-read-and-marked (read-p update-p)
 434   "Copy marks from the virtual group to the component groups.
 435 If READ-P is not nil, update the (un)read status of the components.
 436 If UPDATE-P is not nil, call gnus-group-update-group on the components."
 437   (when nnvirtual-current-group
 438     (let ((unreads (and read-p
 439                         (nnvirtual-partition-sequence
 440                          (gnus-list-of-unread-articles
 441                           (nnvirtual-current-group)))))
 442           (type-marks
 443            (delq nil
 444                  (mapcar (lambda (ml)
 445                            (if (eq (car ml) 'score)
 446                                nil
 447                              (cons (car ml)
 448                                    (nnvirtual-partition-sequence (cdr ml)))))
 449                          (gnus-info-marks (gnus-get-info
 450                                            (nnvirtual-current-group))))))
 451           type groups info)
 452
 453       ;; Ok, atomically move all of the (un)read info, clear any old
 454       ;; marks, and move all of the current marks.  This way if someone
 455       ;; hits C-g, you won't leave the component groups in a half-way state.
 456       (progn
 457         ;; move (un)read
 458         ;; bind for workaround guns-update-read-articles
 459         (let ((gnus-newsgroup-active nil))
 460           (dolist (entry unreads)
 461             (gnus-update-read-articles (car entry) (cdr entry))))
 462
 463         ;; clear all existing marks on the component groups
 464         (dolist (group nnvirtual-component-groups)
 465           (when (and (setq info (gnus-get-info group))
 466                      (gnus-info-marks info))
 467             (gnus-info-set-marks
 468              info
 469              (if (assq 'score (gnus-info-marks info))
 470                  (list (assq 'score (gnus-info-marks info)))
 471                nil))))
 472
 473         ;; Ok, currently type-marks is an assq list with keys of a mark type,
 474         ;; with data of an assq list with keys of component group names
 475         ;; and the articles which correspond to that key/group pair.
 476         (dolist (mark type-marks)
 477           (setq type (car mark))
 478           (setq groups (cdr mark))
 479           (dolist (carticles groups)
 480             (gnus-add-marked-articles (car carticles) type (cdr carticles)
 481                                       nil t))))
 482
 483       ;; possibly update the display, it is really slow
 484       (when update-p
 485         (dolist (group nnvirtual-component-groups)
 486           (gnus-group-update-group group t))))))
 487
 488
 489 (defun nnvirtual-current-group ()
 490   "Return the prefixed name of the current nnvirtual group."
 491   (concat "nnvirtual:" nnvirtual-current-group))
 492
 493
 494
 495 ;;; This is currently O(kn^2) to merge n lists of length k.
 496 ;;; You could do it in O(knlogn), but we have a small n, and the
 497 ;;; overhead of the other approach is probably greater.
 498 (defun nnvirtual-merge-sorted-lists (&rest lists)
 499   "Merge many sorted lists of numbers."
 500   (if (null (cdr lists))
 501       (car lists)
 502     (sort (apply 'nconc lists) '<)))
 503
 504
 505 ;;; We map between virtual articles and real articles in a manner
 506 ;;; which keeps the size of the virtual active list the same as the
 507 ;;; sum of the component active lists.
 508
 509 ;;; To achieve fair mixing of the groups, the last article in each of
 510 ;;; N component groups will be in the last N articles in the virtual
 511 ;;; group.
 512
 513 ;;; If you have 3 components A, B and C, with articles 1-8, 1-5, and
 514 ;;; 6-7 respectively, then the virtual article numbers look like:
 515 ;;;
 516 ;;;  1  2  3  4  5  6  7  8  9  10 11 12 13 14 15
 517 ;;;  A1 A2 A3 A4 B1 A5 B2 A6 B3 A7 B4 C6 A8 B5 C7
 518
 519 ;;; To compute these mappings we generate a couple tables and then
 520 ;;; do some fast operations on them.  Tables for the example above:
 521 ;;;
 522 ;;; Offsets - [(A 0) (B -3) (C -1)]
 523 ;;;
 524 ;;;               a  b  c  d  e
 525 ;;; Mapping - ([  3  0  1  3  0 ]
 526 ;;;            [  6  3  2  9  3 ]
 527 ;;;            [  8  6  3 15  9 ])
 528 ;;;
 529 ;;; (note column 'e' is different in real algorithm, which is slightly
 530 ;;;  different than described here, but this gives you the methodology.)
 531 ;;;
 532 ;;; The basic idea is this, when going from component->virtual, apply
 533 ;;; the appropriate offset to the article number.  Then search the first
 534 ;;; column of the table for a row where 'a' is less than or equal to the
 535 ;;; modified number.  You can see that only group A can therefore go to
 536 ;;; the first row, groups A and B to the second, and all to the last.
 537 ;;; The third column of the table is telling us the number of groups
 538 ;;; which might be able to reach that row (it might increase by more than
 539 ;;; 1 if several groups have the same size).
 540 ;;; Then column 'b' provides an additional offset you apply when you have
 541 ;;; found the correct row.  You then multiply by 'c' and add on the groups
 542 ;;; _position_ in the offset table.  The basic idea here is that on
 543 ;;; any given row we are going to map back and forth using X'=X*c+Y and
 544 ;;; X=(X'/c), Y=(X' mod c).  Then once you've done this transformation,
 545 ;;; you apply a final offset from column 'e' to give the virtual article.
 546 ;;;
 547 ;;; Going the other direction, you instead search on column 'd' instead
 548 ;;; of 'a', and apply everything in reverse order.
 549
 550 ;;; Convert component -> virtual:
 551 ;;; set num = num - Offset(group)
 552 ;;; find first row in Mapping where num <= 'a'
 553 ;;; num = (num-'b')*c + Position(group) + 'e'
 554
 555 ;;; Convert virtual -> component:
 556 ;;; find first row in Mapping where num <= 'd'
 557 ;;; num = num - 'e'
 558 ;;; group_pos = num mod 'c'
 559 ;;; num = (num / 'c') + 'b' + Offset(group_pos)
 560
 561 ;;; Easy no? :)
 562 ;;;
 563 ;;; Well actually, you need to keep column e offset smaller by the 'c'
 564 ;;; column for that line, and always add 1 more when going from
 565 ;;; component -> virtual.  Otherwise you run into a problem with
 566 ;;; unique reverse mapping.
 567
 568 (defun nnvirtual-map-article (article)
 569   "Return a cons of the component group and article corresponding to the given virtual ARTICLE."
 570   (let ((table nnvirtual-mapping-table)
 571         entry group-pos)
 572     (while (and table
 573                 (> article (aref (car table) 3)))
 574       (setq table (cdr table)))
 575     (when (and table
 576                (> article 0))
 577       (setq entry (car table))
 578       (setq article (- article (aref entry 4) 1))
 579       (setq group-pos (mod article (aref entry 2)))
 580       (cons (car (aref nnvirtual-mapping-offsets group-pos))
 581             (+ (/ article (aref entry 2))
 582                (aref entry 1)
 583                (cdr (aref nnvirtual-mapping-offsets group-pos)))
 584             ))
 585     ))
 586
 587
 588
 589 (defun nnvirtual-reverse-map-article (group article)
 590   "Return the virtual article number corresponding to the given component GROUP and ARTICLE."
 591   (when (numberp article)
 592     (let ((table nnvirtual-mapping-table)
 593           (group-pos 0)
 594           entry)
 595       (while (not (string= group (car (aref nnvirtual-mapping-offsets
 596                                             group-pos))))
 597         (setq group-pos (1+ group-pos)))
 598       (setq article (- article (cdr (aref nnvirtual-mapping-offsets
 599                                           group-pos))))
 600       (while (and table
 601                   (> article (aref (car table) 0)))
 602         (setq table (cdr table)))
 603       (setq entry (car table))
 604       (when (and entry
 605                  (> article 0)
 606                  (< group-pos (aref entry 2))) ; article not out of range below
 607         (+ (aref entry 4)
 608            group-pos
 609            (* (- article (aref entry 1))
 610               (aref entry 2))
 611            1))
 612       )))
 613
 614
 615 (defsubst nnvirtual-reverse-map-sequence (group articles)
 616   "Return list of virtual article numbers for all ARTICLES in GROUP.
 617 The ARTICLES should be sorted, and can be a compressed sequence.
 618 If any of the article numbers has no corresponding virtual article,
 619 then it is left out of the result."
 620   (when (numberp (cdr-safe articles))
 621     (setq articles (list articles)))
 622   (let (result a i j new-a)
 623     (while (setq a (pop articles))
 624       (if (atom a)
 625           (setq i a
 626                 j a)
 627         (setq i (car a)
 628               j (cdr a)))
 629       (while (<= i j)
 630         ;; If this is slow, you can optimize by moving article checking
 631         ;; into here.  You don't have to recompute the group-pos,
 632         ;; nor scan the table every time.
 633         (when (setq new-a (nnvirtual-reverse-map-article group i))
 634           (push new-a result))
 635         (setq i (1+ i))))
 636     (nreverse result)))
 637
 638
 639 (defun nnvirtual-partition-sequence (articles)
 640   "Return an association list of component article numbers.
 641 These are indexed by elements of nnvirtual-component-groups, based on
 642 the sequence ARTICLES of virtual article numbers.  ARTICLES should be
 643 sorted, and can be a compressed sequence.  If any of the article
 644 numbers has no corresponding component article, then it is left out of
 645 the result."
 646   (when (numberp (cdr-safe articles))
 647     (setq articles (list articles)))
 648   (let ((carticles (mapcar 'list nnvirtual-component-groups))
 649         a i j article entry)
 650     (while (setq a (pop articles))
 651       (if (atom a)
 652           (setq i a
 653                 j a)
 654         (setq i (car a)
 655               j (cdr a)))
 656       (while (<= i j)
 657         (when (setq article (nnvirtual-map-article i))
 658           (setq entry (assoc (car article) carticles))
 659           (setcdr entry (cons (cdr article) (cdr entry))))
 660         (setq i (1+ i))))
 661     (mapc (lambda (x) (setcdr x (nreverse (cdr x))))
 662           carticles)
 663     carticles))
 664
 665
 666 (defun nnvirtual-create-mapping (dont-check)
 667   "Build the tables necessary to map between component (group, article) to virtual article.
 668 Generate the set of read messages and marks for the virtual group
 669 based on the marks on the component groups."
 670   (let ((cnt 0)
 671         (tot 0)
 672         (M 0)
 673         (i 0)
 674         actives all-unreads all-marks
 675         active min max size unreads marks
 676         next-M next-tot
 677         reads beg)
 678     ;; Ok, we loop over all component groups and collect a lot of
 679     ;; information:
 680     ;; Into actives we place (g size max), where size is max-min+1.
 681     ;; Into all-unreads we put (g unreads).
 682     ;; Into all-marks we put (g marks).
 683     ;; We also increment cnt and tot here, and compute M (max of sizes).
 684     (mapc (lambda (g)
 685             (setq active (or (and dont-check
 686                                   (gnus-active g))
 687                              (gnus-activate-group g))
 688                   min (car active)
 689                   max (cdr active))
 690             (when (and active (>= max min) (not (zerop max)))
 691               ;; store active information
 692               (push (list g (- max min -1) max) actives)
 693               ;; collect unread/mark info for later
 694               (setq unreads (gnus-list-of-unread-articles g))
 695               (setq marks (gnus-info-marks (gnus-get-info g)))
 696               (when gnus-use-cache
 697                 (push (cons 'cache
 698                             (gnus-cache-articles-in-group g))
 699                       marks))
 700               (push (cons g unreads) all-unreads)
 701               (push (cons g marks) all-marks)
 702               ;; count groups, total #articles, and max size
 703               (setq size (- max min -1))
 704               (setq cnt (1+ cnt)
 705                     tot (+ tot size)
 706                     M (max M size))))
 707           nnvirtual-component-groups)
 708
 709     ;; Number of articles in the virtual group.
 710     (setq nnvirtual-mapping-len tot)
 711
 712
 713     ;; We want the actives list sorted by size, to build the tables.
 714     (setq actives (sort actives (lambda (g1 g2) (< (nth 1 g1) (nth 1 g2)))))
 715
 716     ;; Build the offset table.  Largest sized groups are at the front.
 717     (setq nnvirtual-mapping-offsets
 718           (vconcat
 719            (nreverse
 720             (mapcar (lambda (entry)
 721                       (cons (nth 0 entry)
 722                             (- (nth 2 entry) M)))
 723                     actives))))
 724
 725     ;; Build the mapping table.
 726     (setq nnvirtual-mapping-table nil)
 727     (setq actives (mapcar (lambda (entry) (nth 1 entry)) actives))
 728     (while actives
 729       (setq size (car actives))
 730       (setq next-M (- M size))
 731       (setq next-tot (- tot (* cnt size)))
 732       ;; make current row in table
 733       (push (vector M next-M cnt tot (- next-tot cnt))
 734             nnvirtual-mapping-table)
 735       ;; update M and tot
 736       (setq M next-M)
 737       (setq tot next-tot)
 738       ;; subtract the current size from all entries.
 739       (setq actives (mapcar (lambda (x) (- x size)) actives))
 740       ;; remove anything that went to 0.
 741       (while (and actives
 742                   (= (car actives) 0))
 743         (pop actives)
 744         (setq cnt (- cnt 1))))
 745
 746
 747     ;; Now that the mapping tables are generated, we can convert
 748     ;; and combine the separate component unreads and marks lists
 749     ;; into single lists of virtual article numbers.
 750     (setq unreads (apply 'nnvirtual-merge-sorted-lists
 751                          (mapcar (lambda (x)
 752                                    (nnvirtual-reverse-map-sequence
 753                                     (car x) (cdr x)))
 754                                  all-unreads)))
 755     (setq marks (mapcar
 756                  (lambda (type)
 757                    (cons (cdr type)
 758                          (gnus-compress-sequence
 759                           (apply
 760                            'nnvirtual-merge-sorted-lists
 761                            (mapcar (lambda (x)
 762                                      (nnvirtual-reverse-map-sequence
 763                                       (car x)
 764                                       (cdr (assq (cdr type) (cdr x)))))
 765                                    all-marks)))))
 766                  gnus-article-mark-lists))
 767
 768     ;; Remove any empty marks lists, and store.
 769     (setq nnvirtual-mapping-marks nil)
 770     (dolist (mark marks)
 771       (when (cdr mark)
 772         (push mark nnvirtual-mapping-marks)))
 773
 774     ;; We need to convert the unreads to reads.  We compress the
 775     ;; sequence as we go, otherwise it could be huge.
 776     (while (and (<= (incf i) nnvirtual-mapping-len)
 777                 unreads)
 778       (if (= i (car unreads))
 779           (setq unreads (cdr unreads))
 780         ;; try to get a range.
 781         (setq beg i)
 782         (while (and (<= (incf i) nnvirtual-mapping-len)
 783                     (not (= i (car unreads)))))
 784         (setq i (- i 1))
 785         (if (= i beg)
 786             (push i reads)
 787           (push (cons beg i) reads))
 788         ))
 789     (when (<= i nnvirtual-mapping-len)
 790       (if (= i nnvirtual-mapping-len)
 791           (push i reads)
 792         (push (cons i nnvirtual-mapping-len) reads)))
 793
 794     ;; Store the reads list for later use.
 795     (setq nnvirtual-mapping-reads (nreverse reads))
 796
 797     ;; Throw flag to show we changed the info.
 798     (setq nnvirtual-info-installed nil)
 799     ))
 800
 801 (provide 'nnvirtual)
 802
 803 ;;; nnvirtual.el ends here