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

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