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

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