cgit.sxemacs.org Git - gnus/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 cludge. 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 (or (not (file-exists-p (nnkiboze-nov-file-name)))
 149           (not (eq major-mode 'gnus-summary-mode)))
 150       ()
 151     (save-excursion
 152       (let ((unreads gnus-newsgroup-unreads)
 153             (unselected gnus-newsgroup-unselected)
 154             (version-control 'never))
 155         (set-buffer (get-buffer-create "*nnkiboze work*"))
 156         (buffer-disable-undo (current-buffer))
 157         (erase-buffer)
 158         (let ((cur (current-buffer))
 159               article)
 160           (insert-file-contents (nnkiboze-nov-file-name))
 161           (goto-char (point-min))
 162           (while (looking-at "[0-9]+")
 163             (if (or (memq (setq article (read cur)) unreads)
 164                     (memq article unselected))
 165                 (forward-line 1)
 166               (delete-region (progn (beginning-of-line) (point))
 167                              (progn (forward-line 1) (point)))))
 168           (write-file (nnkiboze-nov-file-name))
 169           (kill-buffer (current-buffer)))))
 170     (setq nnkiboze-current-group nil)))
 171
 172 (defun nnkiboze-request-list (&optional server)
 173   (setq nnkiboze-status-string "nnkiboze: LIST is not implemented.")
 174   nil)
 175
 176 (defun nnkiboze-request-newgroups (date &optional server)
 177   "List new groups."
 178   (setq nnkiboze-status-string "NEWGROUPS is not supported.")
 179   nil)
 180
 181 (defun nnkiboze-request-list-newsgroups (&optional server)
 182   (setq nnkiboze-status-string "nnkiboze: LIST NEWSGROUPS is not implemented.")
 183   nil)
 184
 185 (defalias 'nnkiboze-request-post 'nntp-request-post)
 186
 187 (defalias 'nnkiboze-request-post-buffer 'nntp-request-post-buffer)
 188
 189 \f
 190 ;;; Internal functions.
 191
 192 (defun nnkiboze-possibly-change-newsgroups (group)
 193   (setq nnkiboze-current-group group))
 194
 195 (defun nnkiboze-prefixed-name (group)
 196   (gnus-group-prefixed-name group '(nnkiboze "")))
 197
 198 ;;;###autoload
 199 (defun nnkiboze-generate-groups ()
 200   "Usage: emacs -batch -l nnkiboze -f nnkiboze-generate-groups
 201 Finds out what articles are to be part of the nnkiboze groups."
 202   (interactive)
 203   (let ((nnmail-spool-file nil)
 204         (gnus-use-dribble-file nil)
 205         (gnus-read-active-file t)
 206         (gnus-expert-user t))
 207     (gnus))
 208   (let* ((gnus-newsrc-alist (gnus-copy-sequence gnus-newsrc-alist))
 209          (newsrc gnus-newsrc-alist))
 210     (while newsrc
 211       (if (string-match "nnkiboze" (car (car newsrc)))
 212           (nnkiboze-generate-group (car (car newsrc))))
 213       (setq newsrc (cdr newsrc)))))
 214
 215 (defun nnkiboze-score-file (group)
 216   (list (expand-file-name
 217          (concat gnus-kill-files-directory nnkiboze-current-score-group
 218                  "." gnus-score-file-suffix))))
 219
 220 (defun nnkiboze-generate-group (group)
 221   (let* ((info (nth 2 (gnus-gethash group gnus-newsrc-hashtb)))
 222          (newsrc-file (concat nnkiboze-directory group ".newsrc"))
 223          (nov-file (concat nnkiboze-directory group ".nov"))
 224          (regexp (nth 1 (nth 4 info)))
 225          (gnus-expert-user t)
 226          (gnus-large-newsgroup nil)
 227          (version-control 'never)
 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