code.delx.au - gnu-emacs/blob - lisp/nnkiboze.el

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