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

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