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

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