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