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

   1 ;;; nnvirtual.el --- virtual newsgroups access for Gnus
   2
   3 ;; Copyright (C) 1994-2016 Free Software Foundation, Inc.
   4
   5 ;; Author: David Moore <dmoore@ucsd.edu>
   6 ;;      Lars Magne Ingebrigtsen <larsi@gnus.org>
   7 ;;      Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
   8 ;; Keywords: news
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software: you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation, either version 3 of the License, or
  15 ;; (at your option) any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  24
  25 ;;; Commentary:
  26
  27 ;; The other access methods (nntp, nnspool, etc) are general news
  28 ;; access methods.  This module relies on Gnus and can not be used
  29 ;; separately.
  30
  31 ;;; Code:
  32
  33 (require 'nntp)
  34 (require 'nnheader)
  35 (require 'gnus)
  36 (require 'nnoo)
  37 (require 'gnus-util)
  38 (require 'gnus-start)
  39 (require 'gnus-sum)
  40 (require 'gnus-msg)
  41 (eval-when-compile (require 'cl))
  42
  43 (nnoo-declare nnvirtual)
  44
  45 (defvoo nnvirtual-always-rescan t
  46   "If non-nil, always scan groups for unread articles when entering a group.
  47 If this variable is nil and you read articles in a component group
  48 after the virtual group has been activated, the read articles from the
  49 component group will show up when you enter the virtual group.")
  50
  51 (defvoo nnvirtual-component-regexp nil
  52   "Regexp to match component groups.")
  53
  54 (defvoo nnvirtual-component-groups nil
  55   "Component group in this nnvirtual group.")
  56
  57 \f
  58
  59 (defconst nnvirtual-version "nnvirtual 1.1")
  60
  61 (defvoo nnvirtual-current-group nil)
  62
  63 (defvoo nnvirtual-mapping-table nil
  64   "Table of rules on how to map between component group and article number to virtual article number.")
  65
  66 (defvoo nnvirtual-mapping-offsets nil
  67   "Table indexed by component group to an offset to be applied to article numbers in that group.")
  68
  69 (defvoo nnvirtual-mapping-len 0
  70   "Number of articles in this virtual group.")
  71
  72 (defvoo nnvirtual-mapping-reads nil
  73   "Compressed sequence of read articles on the virtual group as computed from the unread status of individual component groups.")
  74
  75 (defvoo nnvirtual-mapping-marks nil
  76   "Compressed marks alist for the virtual group as computed from the marks of individual component groups.")
  77
  78 (defvoo nnvirtual-info-installed nil
  79   "T if we have already installed the group info for this group, and shouldn't blast over it again.")
  80
  81 (defvoo nnvirtual-status-string "")
  82
  83 (autoload 'gnus-cache-articles-in-group "gnus-cache")
  84
  85 \f
  86
  87 ;;; Interface functions.
  88
  89 (nnoo-define-basics nnvirtual)
  90
  91
  92 (deffoo nnvirtual-retrieve-headers (articles &optional newsgroup
  93                                              server fetch-old)
  94   (when (nnvirtual-possibly-change-server server)
  95     (with-current-buffer nntp-server-buffer
  96       (erase-buffer)
  97       (if (stringp (car articles))
  98           'headers
  99         (let ((vbuf (nnheader-set-temp-buffer
 100                      (get-buffer-create " *virtual headers*")))
 101               (carticles (nnvirtual-partition-sequence articles))
 102               (sysname (system-name))
 103               cgroup carticle article result prefix)
 104           (while carticles
 105             (setq cgroup (caar carticles))
 106             (setq articles (cdar carticles))
 107             (pop carticles)
 108             (when (and articles
 109                        (gnus-check-server
 110                         (gnus-find-method-for-group cgroup) t)
 111                        (gnus-request-group cgroup t)
 112                        (setq prefix (gnus-group-real-prefix cgroup))
 113                        ;; FIX FIX FIX we want to check the cache!
 114                        ;; This is probably evil if people have set
 115                        ;; gnus-use-cache to nil themselves, but I
 116                        ;; have no way of finding the true value of it.
 117                        (let ((gnus-use-cache t))
 118                          (setq result (gnus-retrieve-headers
 119                                        articles cgroup nil))))
 120               (set-buffer nntp-server-buffer)
 121               ;; If we got HEAD headers, we convert them into NOV
 122               ;; headers.  This is slow, inefficient and, come to think
 123               ;; of it, downright evil.  So sue me.  I couldn't be
 124               ;; bothered to write a header parse routine that could
 125               ;; parse a mixed HEAD/NOV buffer.
 126               (when (eq result 'headers)
 127                 (nnvirtual-convert-headers))
 128               (goto-char (point-min))
 129               (while (not (eobp))
 130                 (delete-region (point)
 131                                (progn
 132                                  (setq carticle (read nntp-server-buffer))
 133                                  (point)))
 134
 135                 ;; We remove this article from the articles list, if
 136                 ;; anything is left in the articles list after going through
 137                 ;; the entire buffer, then those articles have been
 138                 ;; expired or canceled, so we appropriately update the
 139                 ;; component group below.  They should be coming up
 140                 ;; generally in order, so this shouldn't be slow.
 141                 (setq articles (delq carticle articles))
 142
 143                 (setq article (nnvirtual-reverse-map-article cgroup carticle))
 144                 (if (null article)
 145                     ;; This line has no reverse mapping, that means it
 146                     ;; was an extra article reference returned by nntp.
 147                     (progn
 148                       (beginning-of-line)
 149                       (delete-region (point) (progn (forward-line 1) (point))))
 150                   ;; Otherwise insert the virtual article number,
 151                   ;; and clean up the xrefs.
 152                   (princ article nntp-server-buffer)
 153                   (nnvirtual-update-xref-header cgroup carticle
 154                                                 prefix sysname)
 155                   (forward-line 1))
 156                 )
 157
 158               (set-buffer vbuf)
 159               (goto-char (point-max))
 160               (insert-buffer-substring nntp-server-buffer))
 161             ;; Anything left in articles is expired or canceled.
 162             ;; Could be smart and not tell it about articles already known?
 163             (when articles
 164               (gnus-group-make-articles-read cgroup articles))
 165             )
 166
 167           ;; The headers are ready for reading, so they are inserted into
 168           ;; the nntp-server-buffer, which is where Gnus expects to find
 169           ;; them.
 170           (prog1
 171               (with-current-buffer nntp-server-buffer
 172                 (erase-buffer)
 173                 (insert-buffer-substring vbuf)
 174                 ;; FIX FIX FIX, we should be able to sort faster than
 175                 ;; this if needed, since each cgroup is sorted, we just
 176                 ;; need to merge
 177                 (sort-numeric-fields 1 (point-min) (point-max))
 178                 'nov)
 179             (kill-buffer vbuf)))))))
 180
 181
 182 (defvoo nnvirtual-last-accessed-component-group nil)
 183
 184 (deffoo nnvirtual-request-article (article &optional group server buffer)
 185   (when (nnvirtual-possibly-change-server server)
 186     (if (stringp article)
 187         ;; This is a fetch by Message-ID.
 188         (cond
 189          ((not nnvirtual-last-accessed-component-group)
 190           (nnheader-report
 191            'nnvirtual "Don't know what server to request from"))
 192          (t
 193           (save-excursion
 194             (when buffer
 195               (set-buffer buffer))
 196             (let* ((gnus-override-method nil)
 197                    (gnus-command-method
 198                     (gnus-find-method-for-group
 199                      nnvirtual-last-accessed-component-group)))
 200               (funcall (gnus-get-function gnus-command-method 'request-article)
 201                        article nil (nth 1 gnus-command-method) buffer)))))
 202       ;; This is a fetch by number.
 203       (let* ((amap (nnvirtual-map-article article))
 204              (cgroup (car amap)))
 205         (cond
 206          ((not amap)
 207           (nnheader-report 'nnvirtual "No such article: %s" article))
 208          ((not (gnus-check-group cgroup))
 209           (nnheader-report
 210            'nnvirtual "Can't open server where %s exists" cgroup))
 211          ((not (gnus-request-group cgroup t))
 212           (nnheader-report 'nnvirtual "Can't open component group %s" cgroup))
 213          (t
 214           (setq nnvirtual-last-accessed-component-group cgroup)
 215           (if buffer
 216               (with-current-buffer buffer
 217                 ;; We bind this here to avoid double decoding.
 218                 (let ((gnus-article-decode-hook nil))
 219                   (gnus-request-article-this-buffer (cdr amap) cgroup)))
 220             (gnus-request-article (cdr amap) cgroup))))))))
 221
 222
 223 (deffoo nnvirtual-open-server (server &optional defs)
 224   (unless (assq 'nnvirtual-component-regexp defs)
 225     (push `(nnvirtual-component-regexp ,server)
 226           defs))
 227   (nnoo-change-server 'nnvirtual server defs)
 228   (if nnvirtual-component-groups
 229       t
 230     (setq nnvirtual-mapping-table nil
 231           nnvirtual-mapping-offsets nil
 232           nnvirtual-mapping-len 0
 233           nnvirtual-mapping-reads nil
 234           nnvirtual-mapping-marks nil
 235           nnvirtual-info-installed nil)
 236     (when nnvirtual-component-regexp
 237       ;; Go through the newsrc alist and find all component groups.
 238       (let ((newsrc (cdr gnus-newsrc-alist))
 239             group)
 240         (while (setq group (car (pop newsrc)))
 241           (when (string-match nnvirtual-component-regexp group) ; Match
 242             ;; Add this group to the list of component groups.
 243             (setq nnvirtual-component-groups
 244                   (cons group (delete group nnvirtual-component-groups)))))))
 245     (if (not nnvirtual-component-groups)
 246         (nnheader-report 'nnvirtual "No component groups: %s" server)
 247       t)))
 248
 249
 250 (deffoo nnvirtual-request-group (group &optional server dont-check info)
 251   (nnvirtual-possibly-change-server server)
 252   (setq nnvirtual-component-groups
 253         (delete (nnvirtual-current-group) nnvirtual-component-groups))
 254   (cond
 255    ((null nnvirtual-component-groups)
 256     (setq nnvirtual-current-group nil)
 257     (nnheader-report 'nnvirtual "No component groups in %s" group))
 258    (t
 259     (setq nnvirtual-current-group group)
 260     (nnvirtual-create-mapping dont-check)
 261     (when nnvirtual-always-rescan
 262       (nnvirtual-request-update-info
 263        (nnvirtual-current-group)
 264        (gnus-get-info (nnvirtual-current-group))))
 265     (nnheader-insert "211 %d 1 %d %s\n"
 266                      nnvirtual-mapping-len nnvirtual-mapping-len group))))
 267
 268
 269 (deffoo nnvirtual-request-type (group &optional article)
 270   (if (not article)
 271       'unknown
 272     (if (numberp article)
 273         (let ((mart (nnvirtual-map-article article)))
 274           (if mart
 275               (gnus-request-type (car mart) (cdr mart))))
 276       (gnus-request-type
 277        nnvirtual-last-accessed-component-group nil))))
 278
 279 (deffoo nnvirtual-request-update-mark (group article mark)
 280   (let* ((nart (nnvirtual-map-article article))
 281          (cgroup (car nart)))
 282     (when (and nart
 283                (memq mark gnus-auto-expirable-marks)
 284                ;; The component group might be a virtual group.
 285                (= mark (gnus-request-update-mark cgroup (cdr nart) mark))
 286                (gnus-group-auto-expirable-p cgroup))
 287       (setq mark gnus-expirable-mark)))
 288   mark)
 289
 290
 291 (deffoo nnvirtual-close-group (group &optional server)
 292   (when (and (nnvirtual-possibly-change-server server)
 293              (not (gnus-ephemeral-group-p (nnvirtual-current-group))))
 294     (nnvirtual-update-read-and-marked t t))
 295   t)
 296
 297
 298 (deffoo nnvirtual-request-newgroups (date &optional server)
 299   (nnheader-report 'nnvirtual "NEWGROUPS is not supported."))
 300
 301
 302 (deffoo nnvirtual-request-list-newsgroups (&optional server)
 303   (nnheader-report 'nnvirtual "LIST NEWSGROUPS is not implemented."))
 304
 305
 306 (deffoo nnvirtual-request-update-info (group info &optional server)
 307   (when (and (nnvirtual-possibly-change-server server)
 308              (not nnvirtual-info-installed))
 309     ;; Install the precomputed lists atomically, so the virtual group
 310     ;; is not left in a half-way state in case of C-g.
 311     (gnus-atomic-progn
 312       (setcar (cddr info) nnvirtual-mapping-reads)
 313       (if (nthcdr 3 info)
 314           (setcar (nthcdr 3 info) nnvirtual-mapping-marks)
 315         (when nnvirtual-mapping-marks
 316           (setcdr (nthcdr 2 info) (list nnvirtual-mapping-marks))))
 317       (setq nnvirtual-info-installed t))
 318     t))
 319
 320
 321 (deffoo nnvirtual-catchup-group (group &optional server all)
 322   (when (and (nnvirtual-possibly-change-server server)
 323              (not (gnus-ephemeral-group-p (nnvirtual-current-group))))
 324     ;; copy over existing marks first, in case they set anything
 325     (nnvirtual-update-read-and-marked nil nil)
 326     ;; do a catchup on all component groups
 327     (let ((gnus-group-marked (copy-sequence nnvirtual-component-groups))
 328           (gnus-expert-user t))
 329       ;; Make sure all groups are activated.
 330       (mapc
 331        (lambda (g)
 332          (when (not (numberp (gnus-group-unread g)))
 333            (gnus-activate-group g)))
 334        nnvirtual-component-groups)
 335       (with-current-buffer gnus-group-buffer
 336         (gnus-group-catchup-current nil all)))))
 337
 338
 339 (deffoo nnvirtual-find-group-art (group article)
 340   "Return the real group and article for virtual GROUP and ARTICLE."
 341   (nnvirtual-map-article article))
 342
 343
 344 (deffoo nnvirtual-request-post (&optional server)
 345   (if (not gnus-message-group-art)
 346       (nnheader-report 'nnvirtual "Can't post to an nnvirtual group")
 347     (let ((group (car (nnvirtual-find-group-art
 348                        (car gnus-message-group-art)
 349                        (cdr gnus-message-group-art)))))
 350       (gnus-request-post (gnus-find-method-for-group group)))))
 351
 352
 353 (deffoo nnvirtual-request-expire-articles (articles group
 354                                                     &optional server force)
 355   (nnvirtual-possibly-change-server server)
 356   (setq nnvirtual-component-groups
 357         (delete (nnvirtual-current-group) nnvirtual-component-groups))
 358   (let (unexpired)
 359     (dolist (group nnvirtual-component-groups)
 360       (setq unexpired (nconc unexpired
 361                              (mapcar
 362                               #'(lambda (article)
 363                                   (nnvirtual-reverse-map-article
 364                                    group article))
 365                               (gnus-uncompress-range
 366                                (gnus-group-expire-articles-1 group))))))
 367     (sort (delq nil unexpired) '<)))
 368
 369 \f
 370 ;;; Internal functions.
 371
 372 (defun nnvirtual-convert-headers ()
 373   "Convert HEAD headers into NOV headers."
 374   (with-current-buffer nntp-server-buffer
 375     (let* ((dependencies (make-vector 100 0))
 376            (headers (gnus-get-newsgroup-headers dependencies)))
 377       (erase-buffer)
 378       (mapc 'nnheader-insert-nov headers))))
 379
 380
 381 (defun nnvirtual-update-xref-header (group article prefix sysname)
 382   "Edit current NOV header in current buffer to have an xref to the component group, and also server prefix any existing xref lines."
 383   ;; Move to beginning of Xref field, creating a slot if needed.
 384   (beginning-of-line)
 385   (looking-at
 386    "[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t")
 387   (goto-char (match-end 0))
 388   (unless (search-forward "\t" (point-at-eol) 'move)
 389     (insert "\t"))
 390
 391   ;; Remove any spaces at the beginning of the Xref field.
 392   (while (eq (char-after (1- (point))) ? )
 393     (forward-char -1)
 394     (delete-char 1))
 395
 396   (insert "Xref: " sysname " " group ":")
 397   (princ article (current-buffer))
 398   (insert " ")
 399
 400   ;; If there were existing xref lines, clean them up to have the correct
 401   ;; component server prefix.
 402   (save-restriction
 403     (narrow-to-region (point)
 404                       (or (search-forward "\t" (point-at-eol) t)
 405                           (point-at-eol)))
 406     (goto-char (point-min))
 407     (when (re-search-forward "Xref: *[^\n:0-9 ]+ *" nil t)
 408       (replace-match "" t t))
 409     (goto-char (point-min))
 410     (when (re-search-forward
 411            (concat (regexp-quote (gnus-group-real-name group)) ":[0-9]+")
 412            nil t)
 413       (replace-match "" t t))
 414     (unless (eobp)
 415       (insert " ")
 416       (when (not (string= "" prefix))
 417         (while (re-search-forward "[^ ]+:[0-9]+" nil t)
 418           (save-excursion
 419             (goto-char (match-beginning 0))
 420             (insert prefix))))))
 421
 422   ;; Ensure a trailing \t.
 423   (end-of-line)
 424   (or (eq (char-after (1- (point))) ?\t)
 425       (insert ?\t)))
 426
 427
 428 (defun nnvirtual-possibly-change-server (server)
 429   (or (not server)
 430       (nnoo-current-server-p 'nnvirtual server)
 431       (nnvirtual-open-server server)))
 432
 433
 434 (defun nnvirtual-update-read-and-marked (read-p update-p)
 435   "Copy marks from the virtual group to the component groups.
 436 If READ-P is not nil, update the (un)read status of the components.
 437 If UPDATE-P is not nil, call gnus-group-update-group on the components."
 438   (when nnvirtual-current-group
 439     (let ((unreads (and read-p
 440                         (nnvirtual-partition-sequence
 441                          (gnus-list-of-unread-articles
 442                           (nnvirtual-current-group)))))
 443           (type-marks
 444            (delq nil
 445                  (mapcar (lambda (ml)
 446                            (if (eq (car ml) 'score)
 447                                nil
 448                              (cons (car ml)
 449                                    (nnvirtual-partition-sequence (cdr ml)))))
 450                          (gnus-info-marks (gnus-get-info
 451                                            (nnvirtual-current-group))))))
 452           type groups info)
 453
 454       ;; Ok, atomically move all of the (un)read info, clear any old
 455       ;; marks, and move all of the current marks.  This way if someone
 456       ;; hits C-g, you won't leave the component groups in a half-way state.
 457       (progn
 458         ;; move (un)read
 459         ;; bind for workaround guns-update-read-articles
 460         (let ((gnus-newsgroup-active nil))
 461           (dolist (entry unreads)
 462             (gnus-update-read-articles (car entry) (cdr entry))))
 463
 464         ;; clear all existing marks on the component groups
 465         (dolist (group nnvirtual-component-groups)
 466           (when (and (setq info (gnus-get-info group))
 467                      (gnus-info-marks info))
 468             (gnus-info-set-marks
 469              info
 470              (if (assq 'score (gnus-info-marks info))
 471                  (list (assq 'score (gnus-info-marks info)))
 472                nil))))
 473
 474         ;; Ok, currently type-marks is an assq list with keys of a mark type,
 475         ;; with data of an assq list with keys of component group names
 476         ;; and the articles which correspond to that key/group pair.
 477         (dolist (mark type-marks)
 478           (setq type (car mark))
 479           (setq groups (cdr mark))
 480           (dolist (carticles groups)
 481             (gnus-add-marked-articles (car carticles) type (cdr carticles)
 482                                       nil t))))
 483
 484       ;; possibly update the display, it is really slow
 485       (when update-p
 486         (dolist (group nnvirtual-component-groups)
 487           (gnus-group-update-group group t))))))
 488
 489
 490 (defun nnvirtual-current-group ()
 491   "Return the prefixed name of the current nnvirtual group."
 492   (concat "nnvirtual:" nnvirtual-current-group))
 493
 494
 495
 496 ;;; This is currently O(kn^2) to merge n lists of length k.
 497 ;;; You could do it in O(knlogn), but we have a small n, and the
 498 ;;; overhead of the other approach is probably greater.
 499 (defun nnvirtual-merge-sorted-lists (&rest lists)
 500   "Merge many sorted lists of numbers."
 501   (if (null (cdr lists))
 502       (car lists)
 503     (sort (apply 'nconc lists) '<)))
 504
 505
 506 ;;; We map between virtual articles and real articles in a manner
 507 ;;; which keeps the size of the virtual active list the same as the
 508 ;;; sum of the component active lists.
 509
 510 ;;; To achieve fair mixing of the groups, the last article in each of
 511 ;;; N component groups will be in the last N articles in the virtual
 512 ;;; group.
 513
 514 ;;; If you have 3 components A, B and C, with articles 1-8, 1-5, and
 515 ;;; 6-7 respectively, then the virtual article numbers look like:
 516 ;;;
 517 ;;;  1  2  3  4  5  6  7  8  9  10 11 12 13 14 15
 518 ;;;  A1 A2 A3 A4 B1 A5 B2 A6 B3 A7 B4 C6 A8 B5 C7
 519
 520 ;;; To compute these mappings we generate a couple tables and then
 521 ;;; do some fast operations on them.  Tables for the example above:
 522 ;;;
 523 ;;; Offsets - [(A 0) (B -3) (C -1)]
 524 ;;;
 525 ;;;               a  b  c  d  e
 526 ;;; Mapping - ([  3  0  1  3  0 ]
 527 ;;;            [  6  3  2  9  3 ]
 528 ;;;            [  8  6  3 15  9 ])
 529 ;;;
 530 ;;; (note column 'e' is different in real algorithm, which is slightly
 531 ;;;  different than described here, but this gives you the methodology.)
 532 ;;;
 533 ;;; The basic idea is this, when going from component->virtual, apply
 534 ;;; the appropriate offset to the article number.  Then search the first
 535 ;;; column of the table for a row where 'a' is less than or equal to the
 536 ;;; modified number.  You can see that only group A can therefore go to
 537 ;;; the first row, groups A and B to the second, and all to the last.