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

   1 ;;;; nnvirtual.el --- virtual newsgroups access for (ding) Gnus
   2 ;; Copyright (C) 1994,95 Free Software Foundation, Inc.
   3
   4 ;; Author: Lars Ingebrigtsen <larsi@ifi.uio.no>
   5 ;;      Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
   6 ;; Keywords: news
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to
  22 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  23
  24 ;;; Commentary:
  25
  26 ;; The other access methods (nntp, nnspool, etc) are general news
  27 ;; access methods. This module relies on Gnus and can not be used
  28 ;; separately.
  29
  30 ;;; Code:
  31
  32 (require 'nntp)
  33 (require 'nnheader)
  34 (require 'gnus)
  35
  36 \f
  37
  38 (defconst nnvirtual-version "nnvirtual 0.0"
  39   "Version number of this version of nnvirtual.")
  40
  41 (defvar nnvirtual-group-alist nil)
  42 (defvar nnvirtual-current-group nil)
  43 (defvar nnvirtual-current-groups nil)
  44 (defvar nnvirtual-current-mapping nil)
  45
  46 (defvar nnvirtual-do-not-open nil)
  47
  48 (defvar nnvirtual-status-string "")
  49
  50 \f
  51
  52 ;;; Interface functions.
  53
  54 (defun nnvirtual-retrieve-headers (sequence &optional newsgroup server)
  55   "Retrieve the headers for the articles in SEQUENCE."
  56   (nnvirtual-possibly-change-newsgroups newsgroup server t)
  57   (save-excursion
  58     (set-buffer (get-buffer-create "*virtual headers*"))
  59     (buffer-disable-undo (current-buffer))
  60     (erase-buffer)
  61     (let ((map nnvirtual-current-mapping)
  62           (offset 0)
  63           articles beg group active top article result prefix)
  64       (while sequence
  65         (while (< (car (car map)) (car sequence))
  66           (setq offset (car (car map)))
  67           (setq map (cdr map)))
  68         (setq top (car (car map)))
  69         (setq group (nth 1 (car map)))
  70         (setq prefix (gnus-group-real-prefix group))
  71         (setq active (nth 2 (car map)))
  72         (setq articles nil)
  73         (while (and sequence (<= (car sequence) top))
  74           (setq articles (cons (- (+ active (car sequence)) offset) articles))
  75           (setq sequence (cdr sequence)))
  76         (setq articles (nreverse articles))
  77         (if (and articles
  78                  (setq result (gnus-retrieve-headers articles group)))
  79             (save-excursion
  80               (set-buffer nntp-server-buffer)
  81               ;; If we got HEAD headers, we convert them into NOV
  82               ;; headers. This is slow, inefficient and, come to think
  83               ;; of it, downright evil. So sue me. I couldn't be
  84               ;; bothered to write a header parse routine that could
  85               ;; parse a mixed HEAD/NOV buffer.
  86               (and (eq result 'headers) (nnvirtual-convert-headers))
  87               (goto-char (point-min))
  88               (while (not (eobp))
  89                 (setq beg (point))
  90                 (setq article (read nntp-server-buffer))
  91                 (delete-region beg (point))
  92                 (insert (int-to-string (+ (- article active) offset)))
  93                 (end-of-line)
  94                 (setq beg (point))
  95                 (search-backward "\t")
  96                 (if (not (search-forward "Xref:" beg t))
  97                     (progn
  98                       (end-of-line)
  99                       (or (= (char-after (1- (point))) ?\t)
 100                           (insert ?\t))
 101                       (insert (format "Xref: %s %s:%d\t" (system-name)
 102                                       group article)))
 103                   (if (not (string= "" prefix))
 104                       (while (re-search-forward
 105                               "[^ ]+:[0-9]+"
 106                               (save-excursion (end-of-line) (point)) t)
 107                         (save-excursion
 108                           (goto-char (match-beginning 0))
 109                           (insert prefix)))))
 110                 (forward-line 1))))
 111         (goto-char (point-max))
 112         (insert-buffer-substring nntp-server-buffer))
 113       ;; The headers are ready for reading, so they are inserted into
 114       ;; the nntp-server-buffer, which is where Gnus expects to find
 115       ;; them.
 116       (prog1
 117           (save-excursion
 118             (set-buffer nntp-server-buffer)
 119             (erase-buffer)
 120             (insert-buffer-substring "*virtual headers*")
 121             'nov)
 122         (kill-buffer (current-buffer))))))
 123
 124 (defun nnvirtual-open-server (newsgroups &optional something)
 125   "Open a virtual newsgroup that contains NEWSGROUPS."
 126   (nnheader-init-server-buffer))
 127
 128 (defun nnvirtual-close-server (&rest dum)
 129   "Close news server."
 130   t)
 131
 132 (defun nnvirtual-server-opened (&optional server)
 133   "Return server process status, T or NIL.
 134 If the stream is opened, return T, otherwise return NIL."
 135   (and nntp-server-buffer
 136        (get-buffer nntp-server-buffer)))
 137
 138 (defun nnvirtual-status-message ()
 139   "Return server status response as string."
 140   nnvirtual-status-string)
 141
 142 (defun nnvirtual-request-article (article &optional newsgroup server buffer)
 143   "Select article by message number."
 144   (nnvirtual-possibly-change-newsgroups newsgroup server t)
 145   (and (numberp article)
 146        (let ((map nnvirtual-current-mapping)
 147              (offset 0))
 148          (while (< (car (car map)) article)
 149            (setq offset (car (car map)))
 150            (setq map (cdr map)))
 151          (gnus-request-group (nth 1 (car map)) t)
 152          (gnus-request-article (- (+ (nth 2 (car map)) article) offset)
 153                                (nth 1 (car map)) buffer))))
 154
 155 (defun nnvirtual-request-group (group &optional server dont-check)
 156   "Make GROUP the current newsgroup."
 157   (nnvirtual-possibly-change-newsgroups group server dont-check)
 158   (if (not dont-check)
 159       (let ((map nnvirtual-current-mapping))
 160         (while (cdr map)
 161           (setq map (cdr map)))
 162         (save-excursion
 163           (set-buffer nntp-server-buffer)
 164           (erase-buffer)
 165           (insert (format "211 %d 1 %d %s\n" (car (car map))
 166                           (car (car map)) group)))))
 167   t)
 168
 169 (defun nnvirtual-close-group (group &optional server)
 170   (nnvirtual-possibly-change-newsgroups group server t)
 171   (nnvirtual-update-marked)
 172   (setq nnvirtual-current-group nil
 173         nnvirtual-current-groups nil
 174         nnvirtual-current-mapping nil)
 175   (setq nnvirtual-group-alist
 176         (delq (assoc group nnvirtual-group-alist) nnvirtual-group-alist)))
 177
 178 (defun nnvirtual-request-list (&optional server)
 179   (setq nnvirtual-status-string "nnvirtual: LIST is not implemented.")
 180   nil)
 181
 182 (defun nnvirtual-request-newgroups (date &optional server)
 183   "List new groups."
 184   (setq nnvirtual-status-string "NEWGROUPS is not supported.")
 185   nil)
 186
 187 (defun nnvirtual-request-list-newsgroups (&optional server)
 188   (setq nnvirtual-status-string
 189         "nnvirtual: LIST NEWSGROUPS is not implemented.")
 190   nil)
 191
 192 (fset 'nnvirtual-request-post 'nntp-request-post)
 193
 194 (fset 'nnvirtual-request-post-buffer 'nntp-request-post-buffer)
 195
 196 \f
 197 ;;; Internal functions.
 198
 199 ;; Convert HEAD headers into NOV headers.
 200 (defun nnvirtual-convert-headers ()
 201   (save-excursion
 202     (set-buffer nntp-server-buffer)
 203     (let* ((gnus-newsgroup-dependencies (make-vector 100 0))
 204            (headers (gnus-get-newsgroup-headers))
 205            header)
 206       (erase-buffer)
 207       (while headers
 208         (setq header (car headers)
 209               headers (cdr headers))
 210         (insert (int-to-string (header-number header)) "\t"
 211                 (or (header-subject header) "") "\t"
 212                 (or (header-from header) "") "\t"
 213                 (or (header-date header) "") "\t"
 214                 (or (header-id header) "") "\t"
 215                 (or (header-references header) "") "\t"
 216                 (int-to-string (or (header-chars header) 0)) "\t"
 217                 (int-to-string (or (header-lines header) 0)) "\t"
 218                 (or (header-xref header) "") "\n")))))
 219
 220 (defun nnvirtual-possibly-change-newsgroups (group regexp &optional check)
 221   (let ((inf t))
 222     (or (not group)
 223         (and nnvirtual-current-group
 224              (string= group nnvirtual-current-group))
 225         (and (setq inf (assoc group nnvirtual-group-alist))
 226              (string= (nth 3 inf) regexp)
 227              (progn
 228                (setq nnvirtual-current-group (car inf))
 229                (setq nnvirtual-current-groups (nth 1 inf))
 230                (setq nnvirtual-current-mapping (nth 2 inf)))))
 231     (if (or (not check) (not inf))
 232         (progn
 233           (and inf (setq nnvirtual-group-alist
 234                          (delq inf nnvirtual-group-alist)))
 235           (setq nnvirtual-current-mapping nil)
 236           (setq nnvirtual-current-group group)
 237           (let ((newsrc gnus-newsrc-assoc))
 238             (setq nnvirtual-current-groups nil)
 239             (while newsrc
 240               (and (string-match regexp (car (car newsrc)))
 241                    (setq nnvirtual-current-groups
 242                          (cons (car (car newsrc)) nnvirtual-current-groups)))
 243               (setq newsrc (cdr newsrc))))
 244           (if nnvirtual-current-groups
 245               (progn
 246                 (nnvirtual-create-mapping group)
 247                 (setq nnvirtual-group-alist
 248                       (cons (list group nnvirtual-current-groups
 249                                   nnvirtual-current-mapping regexp)
 250                             nnvirtual-group-alist)))
 251             (setq nnvirtual-status-string
 252                   (format
 253                    "nnvirtual: No newsgroups for this virtual newsgroup"))))))
 254   nnvirtual-current-groups)
 255
 256 (defun nnvirtual-create-mapping (group)
 257   (let* ((group (gnus-group-prefixed-name group (list 'nnvirtual "")))
 258          (info (nth 2 (gnus-gethash group gnus-newsrc-hashtb)))
 259          (groups nnvirtual-current-groups)
 260          (i 1)
 261          (total 0)
 262          (offset 0)
 263          reads unread igroup itotal itreads ireads)
 264     ;; The virtual group doesn't exist. (?)
 265     (or info (error "No such group: %s" group))
 266     (setq nnvirtual-current-mapping nil)
 267     (while groups
 268       ;; Added by Sudish Joseph <joseph@cis.ohio-state.edu>.
 269       (setq igroup (car groups))
 270       (let ((info (nth 2 (gnus-gethash igroup gnus-newsrc-hashtb)))
 271             (active (gnus-gethash igroup gnus-active-hashtb)))
 272         ;; See if the group has had its active list read this session
 273         ;; if not, we do it now.
 274         (if (null active)
 275             (if (gnus-activate-newsgroup igroup)
 276                 (gnus-get-unread-articles-in-group
 277                  info (gnus-gethash igroup gnus-active-hashtb))
 278               (message "Couldn't request newsgroup %s" group)
 279               (ding)))
 280         (setq itotal (1+ (- (cdr active) (car active))))
 281         (if (setq ireads (nth 2 info))
 282             (let ((itreads
 283                    (if (atom (car ireads))
 284                        (setq ireads (list (cons (car ireads) (cdr ireads))))
 285                      (setq ireads (copy-alist ireads)))))
 286               (if (< (cdr (car ireads)) (car active))
 287                   (setq ireads (setq itreads (cdr ireads))))
 288               (if (< (car (car ireads)) (car active))
 289                   (setcar (car ireads) (1+ (car active))))
 290               (while itreads
 291                 (setcar (car itreads)
 292                         (+ (- (car (car itreads)) (car active)) offset))
 293                 (setcdr (car itreads)
 294                         (+ (- (cdr (car itreads)) (car active)) offset))
 295                 (setq itreads (cdr itreads)))
 296               (setq reads (nconc reads ireads))))
 297         (setq offset (+ offset (1- itotal)))
 298         (setq nnvirtual-current-mapping
 299               (cons (list offset igroup (car active))
 300                     nnvirtual-current-mapping))
 301         (setq groups (cdr groups))))
 302     (setq nnvirtual-current-mapping
 303           (nreverse nnvirtual-current-mapping))
 304     (gnus-sethash group (cons 1 offset) gnus-active-hashtb)
 305     (setcar (nthcdr 2 info) reads)
 306
 307     ;; Then we deal with the marks.
 308     (let ((map nnvirtual-current-mapping)
 309           (marks '(tick dormant reply expire score))
 310           (offset 0)
 311           tick dormant reply expire score marked active)
 312       (while map
 313         (setq igroup (nth 1 (car map)))
 314         (setq active (nth 2 (car map)))
 315         (setq marked (nth 3 (nth 2 (gnus-gethash igroup gnus-newsrc-hashtb))))
 316         (let ((m marks))
 317           (while m
 318             (and (assq (car m) marked)
 319                  (set (car m)
 320                       (nconc (mapcar
 321                               (lambda (art)
 322                                 (if (numberp art)
 323                                     (+ (- art active) offset)
 324                                   (cons (+ (- (car art) active) offset)
 325                                         (cdr art))))
 326                               (cdr (assq (car m) marked)))
 327                              (symbol-value (car m)))))
 328             (setq m (cdr m))))
 329         (setq offset (car (car map)))
 330         (setq map (cdr map)))
 331       ;; Put the list of marked articles in the info of the virtual group.
 332       (let ((m marks)
 333             marked)
 334         (while m
 335           (and (symbol-value (car m))
 336                (setq marked (cons (cons (car m) (symbol-value (car m)))
 337                                   marked)))
 338           (setq m (cdr m)))
 339         (if (nthcdr 3 info)
 340             (setcar (nthcdr 3 info) marked)
 341           (setcdr (nthcdr 2 info) (list marked)))))))
 342
 343 (defun nnvirtual-update-marked ()
 344   (let ((mark-lists '((gnus-newsgroup-marked . tick)
 345                       (gnus-newsgroup-dormant . dormant)
 346                       (gnus-newsgroup-expirable . expire)
 347                       (gnus-newsgroup-replied . reply)))
 348         marks art-group group-alist g)
 349     (while mark-lists
 350       (setq marks (symbol-value (car (car mark-lists))))
 351       (while marks
 352         (setq art-group (nnvirtual-art-group (car marks)))
 353         (if (setq g (assoc (car art-group) group-alist))
 354             (nconc g (list (cdr art-group)))
 355           (setq group-alist (cons (list (car art-group) (cdr art-group))
 356                                   group-alist)))
 357         (setq marks (cdr marks)))
 358       (while group-alist
 359         (gnus-add-marked-articles
 360          (car (car group-alist)) (cdr (car mark-lists))
 361          (cdr (car group-alist)) nil t)
 362         (gnus-group-update-group (car (car group-alist)))
 363         (setq group-alist (cdr group-alist)))
 364       (setq mark-lists (cdr mark-lists)))))
 365
 366 (defun nnvirtual-art-group (article)
 367   (let ((map nnvirtual-current-mapping)
 368         (offset 0))
 369     (while (< (car (car map)) (if (numberp article) article (car article)))
 370       (setq offset (car (car map))
 371             map (cdr map)))
 372     (cons (nth 1 (car map))
 373           (if (numberp article)
 374               (- (+ article (nth 2 (car map))) offset)
 375             (cons (- (+ (car article) (nth 2 (car map))) offset)
 376                   (cdr article))))))
 377
 378 (provide 'nnvirtual)
 379
 380 ;;; nnvirtual.el ends here