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 (defconst nnvirtual-version "nnvirtual 0.0"
  37   "Version numbers of this version of nnvirual.")
  38
  39 (defvar nnvirtual-large-newsgroup 50
  40   "The number of the articles which indicates a large newsgroup.
  41 If the number of the articles is greater than the value, verbose
  42 messages will be shown to indicate the current status.")
  43
  44 \f
  45
  46 (defvar nnvirtual-group-alist nil)
  47 (defvar nnvirtual-current-group nil)
  48 (defvar nnvirtual-current-groups nil)
  49 (defvar nnvirtual-current-mapping nil)
  50
  51 (defvar nnvirtual-do-not-open nil)
  52
  53 (defvar nnvirtual-status-string "")
  54
  55 \f
  56
  57 ;;; Interface functions.
  58
  59 (defun nnvirtual-retrieve-headers (sequence &optional newsgroup server)
  60   "Retrieve the headers for the articles in SEQUENCE."
  61   (nnvirtual-possibly-change-newsgroups newsgroup server)
  62   (save-excursion
  63     (set-buffer (get-buffer-create "*virtual headers*"))
  64     (erase-buffer)
  65     (let ((number (length sequence))
  66           (count 0)
  67           (gnus-nov-is-evil t)
  68           (i 0)
  69           prev articles group-articles beg art-info article group)
  70       (if sequence (setq prev (car (aref nnvirtual-current-mapping
  71                                          (car sequence)))))
  72       (while sequence
  73         (setq art-info (aref nnvirtual-current-mapping (car sequence)))
  74         (if (not (equal prev (car art-info)))
  75             (progn
  76               (setq group-articles (cons (list prev (nreverse articles))
  77                                          group-articles))
  78               (setq articles nil)
  79               (setq prev (car art-info))))
  80         (setq articles (cons (cdr art-info) articles))
  81         (setq sequence (cdr sequence)))
  82       (if prev
  83           (setq group-articles (cons (list prev (nreverse articles))
  84                                      group-articles)))
  85       (setq group-articles (nreverse group-articles))
  86       (while group-articles
  87         (setq group (car (car group-articles)))
  88         (gnus-retrieve-headers (car (cdr (car group-articles))) group)
  89         (save-excursion
  90           (set-buffer nntp-server-buffer)
  91           (goto-char 1)
  92           (insert "\n.\n")
  93           (goto-char 1)
  94           (while (search-forward "\n.\n" nil t)
  95             (if (not (looking-at ".[0-9]+ \\([0-9]+\\) "))
  96                 ()
  97               (setq article (string-to-int (gnus-buffer-substring 1 1)))
  98               (setq i 1)
  99               (while (/= article (cdr (aref nnvirtual-current-mapping i)))
 100                 (setq i (1+ i)))
 101               (goto-char (match-beginning 1))
 102               (looking-at "[0-9]+ ")
 103               (replace-match (format "%d " i))
 104               (setq beg (point))
 105               (search-forward "\n.\n" nil t)
 106               (if (not (re-search-backward "^Xref: " beg t))
 107                   (progn
 108                     (forward-char -2)
 109                     (insert (format "Xref: %s %s:%d\n" (system-name)
 110                                     group article))
 111                     (forward-char -1)))
 112               )))
 113         (goto-char (point-max))
 114         (insert-buffer-substring nntp-server-buffer 4)
 115         (setq group-articles (cdr group-articles)))
 116       ;; The headers are ready for reading, so they are inserted into
 117       ;; the nntp-server-buffer, which is where Gnus expects to find
 118       ;; them.
 119       (prog1
 120           (save-excursion
 121             (if (not nntp-server-buffer)
 122                 (setq nntp-server-buffer (get-buffer-create " *nntpd*")))
 123             (set-buffer nntp-server-buffer)
 124             (erase-buffer)
 125             (insert-buffer-substring "*virtual headers*")
 126             'headers)
 127         (kill-buffer (current-buffer))))))
 128
 129 (defun nnvirtual-open-server (newsgroups &optional something)
 130   "Open a virtual newsgroup that contains NEWSGROUPS."
 131   (nnvirtual-open-server-internal))
 132
 133 (defun nnvirtual-close-server (&rest dum)
 134   "Close news server."
 135   (nnvirtual-close-server-internal))
 136
 137 (fset 'nnvirtual-request-quit (symbol-function 'nnvirtual-close-server))
 138
 139 (defun nnvirtual-server-opened (&optional server)
 140   "Return server process status, T or NIL.
 141 If the stream is opened, return T, otherwise return NIL."
 142   (and nntp-server-buffer
 143        (get-buffer nntp-server-buffer)))
 144
 145 (defun nnvirtual-status-message ()
 146   "Return server status response as string."
 147   nnvirtual-status-string)
 148
 149 (defun nnvirtual-request-article (id &optional newsgroup server buffer)
 150   "Select article by message ID (or number)."
 151   (nnvirtual-possibly-change-newsgroups newsgroup server)
 152   (let (art)
 153     (setq art (aref nnvirtual-current-mapping id))
 154     (gnus-request-group (car art))
 155     (gnus-request-article (cdr art) (car art) buffer)))
 156
 157 (defun nnvirtual-request-group (group &optional server dont-check)
 158   "Make GROUP the current newsgroup."
 159   (nnvirtual-possibly-change-newsgroups group server dont-check)
 160   (let ((total (length nnvirtual-current-mapping)))
 161     (save-excursion
 162       (set-buffer nntp-server-buffer)
 163       (erase-buffer)
 164       (insert (format "211 %d %d %d %s\n" total 1 (1- total) group)))
 165     t))
 166
 167 (defun nnvirtual-close-group (group &optional server)
 168   (nnvirtual-possibly-change-newsgroups group server)
 169   (nnvirtual-update-marked)
 170   (setq nnvirtual-current-group nil)
 171   (setq nnvirtual-current-groups nil)
 172   (setq nnvirtual-current-mapping nil)
 173   (let ((inf (member group nnvirtual-group-alist)))
 174     (setq nnvirtual-group-alist (delq inf nnvirtual-group-alist))))
 175
 176 (defun nnvirtual-request-list (&optional server)
 177   (setq nnvirtual-status-string "nnvirtual: LIST is not implemented.")
 178   nil)
 179
 180 (defun nnvirtual-request-newgroups (date &optional server)
 181   "List new groups."
 182   (setq nnvirtual-status-string "NEWGROUPS is not supported.")
 183   nil)
 184
 185 (defun nnvirtual-request-list-newsgroups (&optional server)
 186   (setq nnvirtual-status-string "nnvirtual: LIST NEWSGROUPS is not implemented.")
 187   nil)
 188
 189 (fset 'nnvirtual-request-post 'nntp-request-post)
 190
 191 (fset 'nnvirtual-request-post-buffer 'nntp-request-post-buffer)
 192
 193 \f
 194 ;;; Low-level functions.
 195
 196 (defun nnvirtual-open-server-internal ()
 197   "Fix some internal variables."
 198   (save-excursion
 199     ;; Initialize communication buffer.
 200     (setq nntp-server-buffer (get-buffer-create " *nntpd*"))
 201     (set-buffer nntp-server-buffer)
 202     (buffer-disable-undo (current-buffer))
 203     (kill-all-local-variables)
 204     (setq case-fold-search t)))
 205
 206 (defun nnvirtual-close-server-internal (&rest dum)
 207   "Close connection to news server."
 208   nil)
 209
 210 (defun nnvirtual-possibly-change-newsgroups (group regexp &optional dont-check)
 211   (let (inf)
 212     (or (not group)
 213         (and nnvirtual-current-group
 214              (string= group nnvirtual-current-group))
 215         (and (setq inf (member group nnvirtual-group-alist))
 216              (string= (nth 3 inf) regexp)
 217              (progn
 218                (setq nnvirtual-current-group (car inf))
 219                (setq nnvirtual-current-groups (nth 1 inf))
 220                (setq nnvirtual-current-mapping (nth 2 inf)))))
 221     (if (or (not dont-check) (not inf))
 222         (progn
 223           (and inf (setq nnvirtual-group-alist
 224                          (delq inf nnvirtual-group-alist)))
 225           (setq nnvirtual-current-mapping nil)
 226           (setq nnvirtual-current-group group)
 227           (let ((newsrc gnus-newsrc-assoc))
 228             (setq nnvirtual-current-groups nil)
 229             (while newsrc
 230               (and (string-match regexp (car (car newsrc)))
 231                    (setq nnvirtual-current-groups
 232                          (cons (car (car newsrc)) nnvirtual-current-groups)))
 233               (setq newsrc (cdr newsrc))))
 234           (if nnvirtual-current-groups
 235               (progn
 236                 (nnvirtual-create-mapping group)
 237                 (setq nnvirtual-group-alist
 238                       (cons (list group nnvirtual-current-groups
 239                                   nnvirtual-current-mapping regexp)
 240                             nnvirtual-group-alist)))
 241             (setq nnvirtual-status-string
 242                   (format
 243                    "nnvirtual: No newsgroups for this virtual newsgroup"))))))
 244   nnvirtual-current-groups)
 245
 246 (defun nnvirtual-create-mapping (group)
 247   (let* ((group (gnus-group-prefixed-name group (list 'nnvirtual "")))
 248          (info (nth 2 (gnus-gethash group gnus-newsrc-hashtb)))
 249          (groups nnvirtual-current-groups)
 250          (i 1)
 251          (total 0)
 252          unread igroup)
 253     ;; The virtual group doesn't exist. (?)
 254     (or info (error "No such group: %s" group))
 255     ;; Set the list of read articles to nil.
 256     (setcar (nthcdr 2 info) nil)
 257     (while groups
 258       ;; Added by Sudish Joseph <joseph@cis.ohio-state.edu>.
 259       (setq igroup (car groups))
 260       (let ((info (nth 2 (gnus-gethash igroup gnus-newsrc-hashtb)))
 261             (active (gnus-gethash igroup gnus-active-hashtb)))
 262         ;; see if the group has had its active list read this session
 263         ;; if not, we do it now
 264         (if (null active)
 265             (if (gnus-activate-newsgroup igroup)
 266                 (gnus-get-unread-articles-in-group
 267                  info (gnus-gethash igroup gnus-active-hashtb))
 268               (message "Couldn't request newsgroup %s" group)
 269               (ding))))
 270       (setq unread (car (gnus-gethash (car groups) gnus-newsrc-hashtb)))
 271       (setq total (+ total unread))
 272       (setq groups (cdr groups)))
 273     ;; We create a mapping from nnvirtual article numbers (starting at
 274     ;; 1) to the actual groups numbers.
 275     (setq nnvirtual-current-mapping (make-vector (1+ total) nil))
 276     (let ((groups nnvirtual-current-groups)
 277           (marks '(tick dormant reply expire))
 278           tick dormant reply expire marked)
 279       (while groups
 280         (setq igroup (car groups))
 281         (setq marked (nth 3 (nth 2 (gnus-gethash igroup gnus-newsrc-hashtb))))
 282         (setq unread (gnus-list-of-unread-articles igroup))
 283         (while unread
 284           (aset nnvirtual-current-mapping i (cons igroup (car unread)))
 285           ;; Find out if the article is marked, and enter the marks in
 286           ;; the proper lists.
 287           (let ((m marks))
 288             (while m
 289               (and (memq (car unread) (assq (car m) marked))
 290                    (set (car m) (cons i (symbol-value (car m)))))
 291               (setq m (cdr m))))
 292           (setq i (1+ i))
 293           (setq unread (cdr unread)))
 294         (setq groups (cdr groups)))
 295       ;; Put the list of marked articles in the info of the virtual group.
 296       (let ((m marks)
 297             marked)
 298         (while m
 299           (and (symbol-value (car m))
 300                (setq marked (cons (cons (car m) (symbol-value (car m)))
 301                                   marked)))
 302           (setq m (cdr m)))
 303         (if (nthcdr 3 info)
 304             (setcar (nthcdr 3 info) marked)
 305           (setcdr (nthcdr 2 info) (list marked)))))))
 306
 307 (defun nnvirtual-update-marked ()
 308   (let ((mark-lists '((gnus-newsgroup-marked . tick)
 309                       (gnus-newsgroup-dormant . dormant)
 310                       (gnus-newsgroup-expirable . expire)
 311                       (gnus-newsgroup-replied . reply)))
 312         marks art-group group-alist g)
 313     (while mark-lists
 314       (setq marks (symbol-value (car (car mark-lists))))
 315       (while marks
 316         (setq art-group (aref nnvirtual-current-mapping (car marks)))
 317         (if (setq g (assoc (car art-group) group-alist))
 318             (nconc g (list (cdr art-group)))
 319           (setq group-alist (cons (list (car art-group) (cdr art-group))
 320                                   group-alist)))
 321         (setq marks (cdr marks)))
 322       (while group-alist
 323         (gnus-add-marked-articles (car (car group-alist))
 324                                   (cdr (car mark-lists))
 325                                   (cdr (car group-alist)))
 326         (gnus-group-update-group (car (car group-alist)))
 327         (setq group-alist (cdr group-alist)))
 328       (setq mark-lists (cdr mark-lists)))))
 329
 330 (provide 'nnvirtual)
 331
 332 ;;; nnvirtual.el ends here