lisp/nnkiboze.el

   1 ;;; nnkiboze.el --- select virtual news access for Gnus
   2
   3 ;; Copyright (C) 1995 Free Software Foundation, Inc.
   4
   5 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
   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 the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  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 'gnus-score)
  37
  38 (defvar nnkiboze-directory
  39   (expand-file-name (or gnus-article-save-directory "~/News/"))
  40   "nnkiboze will put its files in this directory.")
  41
  42 \f
  43
  44 (defconst nnkiboze-version "nnkiboze 1.0"
  45   "Version numbers of this version of nnkiboze.")
  46
  47 (defvar nnkiboze-current-group nil)
  48 (defvar nnkiboze-current-score-group "")
  49 (defvar nnkiboze-status-string "")
  50
  51 \f
  52
  53 ;;; Interface functions.
  54
  55 (defun nnkiboze-retrieve-headers (articles &optional group server)
  56   (nnkiboze-possibly-change-newsgroups group)
  57   (if gnus-nov-is-evil
  58       nil
  59     (if (stringp (car articles))
  60         'headers
  61       (let ((first (car articles))
  62             (last (progn (while (cdr articles) (setq articles (cdr articles)))
  63                          (car articles)))
  64             (nov (nnkiboze-nov-file-name)))
  65         (if (file-exists-p nov)
  66             (save-excursion
  67               (set-buffer nntp-server-buffer)
  68               (erase-buffer)
  69               (insert-file-contents nov)
  70               (goto-char (point-min))
  71               (while (and (not (eobp)) (< first (read (current-buffer))))
  72                 (forward-line 1))
  73               (beginning-of-line)
  74               (if (not (eobp)) (delete-region 1 (point)))
  75               (while (and (not (eobp)) (>= last (read (current-buffer))))
  76                 (forward-line 1))
  77               (beginning-of-line)
  78               (if (not (eobp)) (delete-region (point) (point-max)))
  79               'nov))))))
  80
  81 (defun nnkiboze-open-server (newsgroups &optional something)
  82   "Open a virtual newsgroup that contains NEWSGROUPS."
  83   (gnus-make-directory nnkiboze-directory)
  84   (nnheader-init-server-buffer))
  85
  86 (defun nnkiboze-close-server (&rest dum)
  87   "Close news server."
  88   t)
  89
  90 (defalias 'nnkiboze-request-quit (symbol-function 'nnkiboze-close-server))
  91
  92 (defun nnkiboze-server-opened (&optional server)
  93   "Return server process status, T or NIL.
  94 If the stream is opened, return T, otherwise return NIL."
  95   (and nntp-server-buffer
  96        (get-buffer nntp-server-buffer)))
  97
  98 (defun nnkiboze-status-message (&optional server)
  99   "Return server status response as string."
 100   nnkiboze-status-string)
 101
 102 (defun nnkiboze-request-article (article &optional newsgroup server buffer)
 103   "Select article by message number."
 104   (nnkiboze-possibly-change-newsgroups newsgroup)
 105   (if (not (numberp article))
 106       ;; This is a real kludge. It might not work at times, but it
 107       ;; does no harm I think. The only alternative is to offer no
 108       ;; article fetching by message-id at all.
 109       (nntp-request-article article newsgroup gnus-nntp-server buffer)
 110     (let* ((header (gnus-get-header-by-number article))
 111            (xref (mail-header-xref header))
 112            igroup iarticle)
 113       (or xref (error "nnkiboze: No xref"))
 114       (or (string-match " \\([^ ]+\\):\\([0-9]+\\)" xref)
 115           (error "nnkiboze: Malformed xref"))
 116       (setq igroup (substring xref (match-beginning 1) (match-end 1)))
 117       (setq iarticle (string-to-int
 118                       (substring xref (match-beginning 2) (match-end 2))))
 119       (and (gnus-request-group igroup t)
 120            (gnus-request-article iarticle igroup buffer)))))
 121
 122 (defun nnkiboze-request-group (group &optional server dont-check)
 123   "Make GROUP the current newsgroup."
 124   (nnkiboze-possibly-change-newsgroups group)
 125   (if dont-check
 126       ()
 127     (let ((nov-file (nnkiboze-nov-file-name))
 128           beg end total)
 129       (save-excursion
 130         (set-buffer nntp-server-buffer)
 131         (erase-buffer)
 132         (if (not (file-exists-p nov-file))
 133             (insert (format "211 0 0 0 %s\n" group))
 134           (insert-file-contents nov-file)
 135           (if (zerop (buffer-size))
 136               (insert (format "211 0 0 0 %s\n" group))
 137             (goto-char (point-min))
 138             (and (looking-at "[0-9]+") (setq beg (read (current-buffer))))
 139             (goto-char (point-max))
 140             (and (re-search-backward "^[0-9]" nil t)
 141                  (setq end (read (current-buffer))))
 142             (setq total (count-lines (point-min) (point-max)))
 143             (erase-buffer)
 144             (insert (format "211 %d %d %d %s\n" total beg end group)))))))
 145   t)
 146
 147 (defun nnkiboze-close-group (group &optional server)
 148   (nnkiboze-possibly-change-newsgroups group)
 149   ;; Remove NOV lines of articles that are marked as read.
 150   (if (or (not (file-exists-p (nnkiboze-nov-file-name)))
 151           (not (eq major-mode 'gnus-summary-mode)))
 152       ()
 153     (save-excursion
 154       (let ((unreads gnus-newsgroup-unreads)
 155             (unselected gnus-newsgroup-unselected))
 156         (set-buffer (get-buffer-create "*nnkiboze work*"))
 157         (buffer-disable-undo (current-buffer))
 158         (erase-buffer)
 159         (let ((cur (current-buffer))
 160               article)
 161           (insert-file-contents (nnkiboze-nov-file-name))
 162           (goto-char (point-min))
 163           (while (looking-at "[0-9]+")
 164             (if (or (memq (setq article (read cur)) unreads)
 165                     (memq article unselected))
 166                 (forward-line 1)
 167               (delete-region (progn (beginning-of-line) (point))
 168                              (progn (forward-line 1) (point)))))
 169           (write-file (nnkiboze-nov-file-name))
 170           (kill-buffer (current-buffer)))))
 171     (setq nnkiboze-current-group nil)))
 172
 173 (defun nnkiboze-request-list (&optional server)
 174   (setq nnkiboze-status-string "nnkiboze: LIST is not implemented.")
 175   nil)
 176
 177 (defun nnkiboze-request-newgroups (date &optional server)
 178   "List new groups."
 179   (setq nnkiboze-status-string "NEWGROUPS is not supported.")
 180   nil)
 181
 182 (defun nnkiboze-request-list-newsgroups (&optional server)
 183   (setq nnkiboze-status-string "nnkiboze: LIST NEWSGROUPS is not implemented.")
 184   nil)
 185
 186 (defalias 'nnkiboze-request-post 'nntp-request-post)
 187
 188 (defalias 'nnkiboze-request-post-buffer 'nntp-request-post-buffer)
 189
 190 \f
 191 ;;; Internal functions.
 192
 193 (defun nnkiboze-possibly-change-newsgroups (group)
 194   (setq nnkiboze-current-group group))
 195
 196 (defun nnkiboze-prefixed-name (group)
 197   (gnus-group-prefixed-name group '(nnkiboze "")))
 198
 199 ;;;###autoload
 200 (defun nnkiboze-generate-groups ()
 201   "Usage: emacs -batch -l nnkiboze -f nnkiboze-generate-groups
 202 Finds out what articles are to be part of the nnkiboze groups."
 203   (interactive)
 204   (let ((nnmail-spool-file nil)
 205         (gnus-use-dribble-file nil)
 206         (gnus-read-active-file t)
 207         (gnus-expert-user t))
 208     (gnus))
 209   (let* ((gnus-newsrc-alist (gnus-copy-sequence gnus-newsrc-alist))
 210          (newsrc gnus-newsrc-alist))
 211     (while newsrc
 212       (if (string-match "nnkiboze" (car (car newsrc)))
 213           (nnkiboze-generate-group (car (car newsrc))))
 214       (setq newsrc (cdr newsrc)))))
 215
 216 (defun nnkiboze-score-file (group)
 217   (list (expand-file-name
 218          (concat gnus-kill-files-directory nnkiboze-current-score-group
 219                  "." gnus-score-file-suffix))))
 220
 221 (defun nnkiboze-generate-group (group)
 222   (let* ((info (nth 2 (gnus-gethash group gnus-newsrc-hashtb)))
 223          (newsrc-file (concat nnkiboze-directory group ".newsrc"))
 224          (nov-file (concat nnkiboze-directory group ".nov"))
 225          (regexp (nth 1 (nth 4 info)))
 226          (gnus-expert-user t)
 227          (gnus-large-newsgroup nil)
 228          (gnus-score-find-score-files-function 'nnkiboze-score-file)
 229          gnus-select-group-hook gnus-summary-prepare-hook
 230          gnus-thread-sort-functions gnus-show-threads
 231          gnus-visual
 232          method nnkiboze-newsrc nov-buffer gname newsrc active
 233          ginfo lowest)
 234     (setq nnkiboze-current-score-group group)
 235     (or info (error "No such group: %s" group))
 236     (and (file-exists-p newsrc-file) (load newsrc-file))
 237     (save-excursion
 238       (set-buffer (setq nov-buffer (find-file-noselect nov-file)))
 239       (buffer-disable-undo (current-buffer)))
 240     ;; Go through the active hashtb and add new all groups that match the
 241     ;; kiboze regexp.
 242     (mapatoms
 243      (lambda (group)
 244        (if (and (string-match regexp (setq gname (symbol-name group))) ; Match
 245                 (not (assoc gname nnkiboze-newsrc)) ; It isn't registered
 246                 (numberp (car (symbol-value group))) ; It is active
 247                 (not (string-match "^nnkiboze:" gname))) ; Exclude kibozes
 248            (setq nnkiboze-newsrc
 249                  (cons (cons gname (1- (car (symbol-value group))))
 250                        nnkiboze-newsrc))))
 251      gnus-active-hashtb)
 252     (setq newsrc nnkiboze-newsrc)
 253     (while newsrc
 254       (if (not (setq active (gnus-gethash
 255                              (car (car newsrc)) gnus-active-hashtb)))
 256           (setq nnkiboze-newsrc (delq (car newsrc) nnkiboze-newsrc))
 257         (switch-to-buffer gnus-group-buffer)
 258         (gnus-group-jump-to-group (car (car newsrc)))
 259         (if (and (setq ginfo (nth 2 (gnus-gethash (gnus-group-group-name)
 260                                                   gnus-newsrc-hashtb)))
 261                  (nth 3 ginfo))
 262             (setcar (nthcdr 3 ginfo) nil))
 263         (if (not (and (or (not ginfo)
 264                           (> (length (gnus-list-of-unread-articles
 265                                       (car ginfo))) 0))
 266                       (progn
 267                         (gnus-group-select-group nil)
 268                         (eq major-mode 'gnus-summary-mode))))
 269             ()
 270           (setq lowest (cdr (car newsrc)))
 271           (setq method (gnus-find-method-for-group gnus-newsgroup-name))
 272           (and (eq method gnus-select-method) (setq method nil))
 273           (while gnus-newsgroup-scored
 274             (if (> (car (car gnus-newsgroup-scored)) lowest)
 275                 (nnkiboze-enter-nov
 276                  nov-buffer
 277                  (gnus-get-header-by-number (car (car gnus-newsgroup-scored)))
 278                  (if method
 279                      (gnus-group-prefixed-name gnus-newsgroup-name method)
 280                    gnus-newsgroup-name)))
 281             (setq gnus-newsgroup-scored (cdr gnus-newsgroup-scored)))
 282           (gnus-summary-quit)))
 283       (setcdr (car newsrc) (car active))
 284       (setq newsrc (cdr newsrc)))
 285     (set-buffer nov-buffer)
 286     (save-buffer)
 287     (kill-buffer (current-buffer))
 288     (set-buffer (get-buffer-create "*nnkiboze work*"))
 289     (buffer-disable-undo (current-buffer))
 290     (erase-buffer)
 291     (insert "(setq nnkiboze-newsrc '" (prin1-to-string nnkiboze-newsrc)
 292             ")\n")
 293     (write-file newsrc-file)
 294     (kill-buffer (current-buffer))
 295     (switch-to-buffer gnus-group-buffer)
 296     (gnus-group-list-groups 5 nil)))
 297
 298 (defun nnkiboze-enter-nov (buffer header group)
 299   (save-excursion
 300     (set-buffer buffer)
 301     (goto-char (point-max))
 302     (let ((xref (mail-header-xref header))
 303           (prefix (gnus-group-real-prefix group))
 304           (first t)
 305           article)
 306       (if (zerop (forward-line -1))
 307           (progn
 308             (setq article (1+ (read (current-buffer))))
 309             (forward-line 1))
 310         (setq article 1))
 311       (insert (int-to-string article) "\t"
 312               (or (mail-header-subject header) "") "\t"
 313               (or (mail-header-from header) "") "\t"
 314               (or (mail-header-date header) "") "\t"
 315               (or (mail-header-id header) "") "\t"
 316               (or (mail-header-references header) "") "\t"
 317               (int-to-string (or (mail-header-chars header) 0)) "\t"
 318               (int-to-string (or (mail-header-lines header) 0)) "\t")
 319       (if (or (not xref) (equal "" xref))
 320           (insert "Xref: " (system-name) " " group ":"
 321                   (int-to-string (mail-header-number header))
 322                   "\t\n")
 323         (insert (mail-header-xref header) "\t\n")
 324         (search-backward "\t" nil t)
 325         (search-backward "\t" nil t)
 326         (while (re-search-forward
 327                 "[^ ]+:[0-9]+"
 328                 (save-excursion (end-of-line) (point)) t)
 329           (if first
 330               ;; The first xref has to be the group this article
 331               ;; really came for - this is the article nnkiboze
 332               ;; will request when it is asked for the article.
 333               (save-excursion
 334                 (goto-char (match-beginning 0))
 335                 (insert prefix group ":"
 336                         (int-to-string (mail-header-number header)) " ")
 337                 (setq first nil)))
 338           (save-excursion
 339             (goto-char (match-beginning 0))
 340             (insert prefix)))))))
 341
 342 (defun nnkiboze-nov-file-name ()
 343   (concat nnkiboze-directory
 344           (nnkiboze-prefixed-name nnkiboze-current-group) ".nov"))
 345
 346 (provide 'nnkiboze)
 347
 348 ;;; nnkiboze.el ends here