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, 2009, 2010 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 (autoload 'gnus-cache-articles-in-group "gnus-cache")
  85
  86 \f
  87
  88 ;;; Interface functions.
  89
  90 (nnoo-define-basics nnvirtual)
  91
  92
  93 (deffoo nnvirtual-retrieve-headers (articles &optional newsgroup
  94                                              server fetch-old)
  95   (when (nnvirtual-possibly-change-server server)
  96     (save-excursion
  97       (set-buffer nntp-server-buffer)
  98       (erase-buffer)
  99       (if (stringp (car articles))
 100           'headers
 101         (let ((vbuf (nnheader-set-temp-buffer
 102                      (get-buffer-create " *virtual headers*")))
 103               (carticles (nnvirtual-partition-sequence articles))
 104               (system-name (system-name))
 105               cgroup carticle article result prefix)
 106           (while carticles
 107             (setq cgroup (caar carticles))
 108             (setq articles (cdar carticles))
 109             (pop carticles)
 110             (when (and articles
 111                        (gnus-check-server
 112                         (gnus-find-method-for-group cgroup) t)
 113                        (gnus-request-group cgroup t)
 114                        (setq prefix (gnus-group-real-prefix cgroup))
 115                        ;; FIX FIX FIX we want to check the cache!
 116                        ;; This is probably evil if people have set
 117                        ;; gnus-use-cache to nil themselves, but I
 118                        ;; have no way of finding the true value of it.
 119                        (let ((gnus-use-cache t))
 120                          (setq result (gnus-retrieve-headers
 121                                        articles cgroup nil))))
 122               (set-buffer nntp-server-buffer)
 123               ;; If we got HEAD headers, we convert them into NOV
 124               ;; headers.  This is slow, inefficient and, come to think
 125               ;; of it, downright evil.  So sue me.  I couldn't be
 126               ;; bothered to write a header parse routine that could
 127               ;; parse a mixed HEAD/NOV buffer.
 128               (when (eq result 'headers)
 129                 (nnvirtual-convert-headers))
 130               (goto-char (point-min))
 131               (while (not (eobp))
 132                 (delete-region (point)
 133                                (progn
 134                                  (setq carticle (read nntp-server-buffer))
 135                                  (point)))
 136
 137                 ;; We remove this article from the articles list, if
 138                 ;; anything is left in the articles list after going through
 139                 ;; the entire buffer, then those articles have been
 140                 ;; expired or canceled, so we appropriately update the
 141                 ;; component group below.  They should be coming up
 142                 ;; generally in order, so this shouldn't be slow.
 143                 (setq articles (delq carticle articles))
 144
 145                 (setq article (nnvirtual-reverse-map-article cgroup carticle))
 146                 (if (null article)
 147                     ;; This line has no reverse mapping, that means it
 148                     ;; was an extra article reference returned by nntp.
 149                     (progn
 150                       (beginning-of-line)
 151                       (delete-region (point) (progn (forward-line 1) (point))))
 152                   ;; Otherwise insert the virtual article number,
 153                   ;; and clean up the xrefs.
 154                   (princ article nntp-server-buffer)
 155                   (nnvirtual-update-xref-header cgroup carticle
 156                                                 prefix system-name)
 157                   (forward-line 1))
 158                 )
 159
 160               (set-buffer vbuf)
 161               (goto-char (point-max))
 162               (insert-buffer-substring nntp-server-buffer))
 163             ;; Anything left in articles is expired or canceled.
 164             ;; Could be smart and not tell it about articles already known?
 165             (when articles
 166               (gnus-group-make-articles-read cgroup articles))
 167             )
 168
 169           ;; The headers are ready for reading, so they are inserted into
 170           ;; the nntp-server-buffer, which is where Gnus expects to find
 171           ;; them.
 172           (prog1
 173               (save-excursion
 174                 (set-buffer nntp-server-buffer)
 175                 (erase-buffer)
 176                 (insert-buffer-substring vbuf)
 177                 ;; FIX FIX FIX, we should be able to sort faster than
 178                 ;; this if needed, since each cgroup is sorted, we just
 179                 ;; need to merge
 180                 (sort-numeric-fields 1 (point-min) (point-max))
 181                 'nov)
 182             (kill-buffer vbuf)))))))
 183
 184
 185 (defvoo nnvirtual-last-accessed-component-group nil)
 186
 187 (deffoo nnvirtual-request-article (article &optional group server buffer)
 188   (when (nnvirtual-possibly-change-server server)
 189     (if (stringp article)
 190         ;; This is a fetch by Message-ID.
 191         (cond
 192          ((not nnvirtual-last-accessed-component-group)
 193           (nnheader-report
 194            'nnvirtual "Don't know what server to request from"))
 195          (t
 196           (save-excursion
 197             (when buffer
 198               (set-buffer buffer))
 199             (let* ((gnus-override-method nil)
 200                    (method (gnus-find-method-for-group
 201                             nnvirtual-last-accessed-component-group)))
 202               (funcall (gnus-get-function method 'request-article)
 203                        article nil (nth 1 method) buffer)))))
 204       ;; This is a fetch by number.
 205       (let* ((amap (nnvirtual-map-article article))
 206              (cgroup (car amap)))
 207         (cond
 208          ((not amap)
 209           (nnheader-report 'nnvirtual "No such article: %s" article))
 210          ((not (gnus-check-group cgroup))
 211           (nnheader-report
 212            'nnvirtual "Can't open server where %s exists" cgroup))
 213          ((not (gnus-request-group cgroup t))
 214           (nnheader-report 'nnvirtual "Can't open component group %s" cgroup))
 215          (t
 216           (setq nnvirtual-last-accessed-component-group cgroup)
 217           (if buffer
 218               (save-excursion
 219                 (set-buffer buffer)
 220                 ;; We bind this here to avoid double decoding.
 221                 (let ((gnus-article-decode-hook nil))
 222                   (gnus-request-article-this-buffer (cdr amap) cgroup)))
 223             (gnus-request-article (cdr amap) cgroup))))))))
 224
 225
 226 (deffoo nnvirtual-open-server (server &optional defs)
 227   (unless (assq 'nnvirtual-component-regexp defs)
 228     (push `(nnvirtual-component-regexp ,server)
 229           defs))
 230   (nnoo-change-server 'nnvirtual server defs)
 231   (if nnvirtual-component-groups
 232       t
 233     (setq nnvirtual-mapping-table nil
 234           nnvirtual-mapping-offsets nil
 235           nnvirtual-mapping-len 0
 236           nnvirtual-mapping-reads nil
 237           nnvirtual-mapping-marks nil
 238           nnvirtual-info-installed nil)
 239     (when nnvirtual-component-regexp
 240       ;; Go through the newsrc alist and find all component groups.
 241       (let ((newsrc (cdr gnus-newsrc-alist))
 242             group)
 243         (while (setq group (car (pop newsrc)))
 244           (when (string-match nnvirtual-component-regexp group) ; Match
 245             ;; Add this group to the list of component groups.
 246             (setq nnvirtual-component-groups
 247                   (cons group (delete group nnvirtual-component-groups)))))))
 248     (if (not nnvirtual-component-groups)
 249         (nnheader-report 'nnvirtual "No component groups: %s" server)
 250       t)))
 251
 252
 253 (deffoo nnvirtual-request-group (group &optional server dont-check)
 254   (nnvirtual-possibly-change-server server)
 255   (setq nnvirtual-component-groups
 256         (delete (nnvirtual-current-group) nnvirtual-component-groups))
 257   (cond
 258    ((null nnvirtual-component-groups)
 259     (setq nnvirtual-current-group nil)
 260     (nnheader-report 'nnvirtual "No component groups in %s" group))
 261    (t
 262     (setq nnvirtual-current-group group)
 263     (when (or (not dont-check)
 264               nnvirtual-always-rescan)
 265       (nnvirtual-create-mapping)
 266       (when nnvirtual-always-rescan
 267         (nnvirtual-request-update-info
 268          (nnvirtual-current-group)
 269          (gnus-get-info (nnvirtual-current-group)))))
 270     (nnheader-insert "211 %d 1 %d %s\n"
 271                      nnvirtual-mapping-len nnvirtual-mapping-len group))))
 272
 273
 274 (deffoo nnvirtual-request-type (group &optional article)
 275   (if (not article)
 276       'unknown
 277     (if (numberp article)
 278         (let ((mart (nnvirtual-map-article article)))
 279           (if mart
 280               (gnus-request-type (car mart) (cdr mart))))
 281       (gnus-request-type
 282        nnvirtual-last-accessed-component-group nil))))
 283
 284 (deffoo nnvirtual-request-update-mark (group article mark)
 285   (let* ((nart (nnvirtual-map-article article))
 286          (cgroup (car nart)))
 287     (when (and nart
 288                (memq mark gnus-auto-expirable-marks)
 289                ;; The component group might be a virtual group.
 290                (= mark (gnus-request-update-mark cgroup (cdr nart) mark))
 291                (gnus-group-auto-expirable-p cgroup))
 292       (setq mark gnus-expirable-mark)))
 293   mark)
 294
 295
 296 (deffoo nnvirtual-close-group (group &optional server)
 297   (when (and (nnvirtual-possibly-change-server server)
 298              (not (gnus-ephemeral-group-p (nnvirtual-current-group))))
 299     (nnvirtual-update-read-and-marked t t))
 300   t)
 301
 302
 303 (deffoo nnvirtual-request-list (&optional server)
 304   (nnheader-report 'nnvirtual "LIST is not implemented."))
 305
 306
 307 (deffoo nnvirtual-request-newgroups (date &optional server)
 308   (nnheader-report 'nnvirtual "NEWGROUPS is not supported."))
 309
 310
 311 (deffoo nnvirtual-request-list-newsgroups (&optional server)
 312   (nnheader-report 'nnvirtual "LIST NEWSGROUPS is not implemented."))
 313
 314
 315 (deffoo nnvirtual-request-update-info (group info &optional server)
 316   (when (and (nnvirtual-possibly-change-server server)
 317              (not nnvirtual-info-installed))
 318     ;; Install the precomputed lists atomically, so the virtual group
 319     ;; is not left in a half-way state in case of C-g.
 320     (gnus-atomic-progn
 321       (setcar (cddr info) nnvirtual-mapping-reads)
 322       (if (nthcdr 3 info)
 323           (setcar (nthcdr 3 info) nnvirtual-mapping-marks)
 324         (when nnvirtual-mapping-marks
 325           (setcdr (nthcdr 2 info) (list nnvirtual-mapping-marks))))
 326       (setq nnvirtual-info-installed t))
 327     t))
 328
 329
 330 (deffoo nnvirtual-catchup-group (group &optional server all)
 331   (when (and (nnvirtual-possibly-change-server server)
 332              (not (gnus-ephemeral-group-p (nnvirtual-current-group))))
 333     ;; copy over existing marks first, in case they set anything
 334     (nnvirtual-update-read-and-marked nil nil)
 335     ;; do a catchup on all component groups
 336     (let ((gnus-group-marked (copy-sequence nnvirtual-component-groups))
 337           (gnus-expert-user t))
 338       ;; Make sure all groups are activated.
 339       (mapc
 340        (lambda (g)
 341          (when (not (numberp (gnus-group-unread g)))
 342            (gnus-activate-group g)))
 343        nnvirtual-component-groups)
 344       (save-excursion
 345         (set-buffer gnus-group-buffer)
 346         (gnus-group-catchup-current nil all)))))
 347
 348
 349 (deffoo nnvirtual-find-group-art (group article)
 350   "Return the real group and article for virtual GROUP and ARTICLE."
 351   (nnvirtual-map-article article))
 352
 353
 354 (deffoo nnvirtual-request-post (&optional server)
 355   (if (not gnus-message-group-art)
 356       (nnheader-report 'nnvirtual "Can't post to an nnvirtual group")
 357     (let ((group (car (nnvirtual-find-group-art
 358                        (car gnus-message-group-art)
 359                        (cdr gnus-message-group-art)))))
 360       (gnus-request-post (gnus-find-method-for-group group)))))
 361
 362
 363 (deffoo nnvirtual-request-expire-articles (articles group
 364                                                     &optional server force)
 365   (nnvirtual-possibly-change-server server)
 366   (setq nnvirtual-component-groups
 367         (delete (nnvirtual-current-g