home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 31 / CDASC_31_1996_juillet_aout.iso / vrac_os2 / e31el3.zip / EMACS / 19.31 / LISP / NNKIBOZE.EL < prev    next >
Lisp/Scheme  |  1996-01-20  |  13KB  |  349 lines
  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.  
  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.  
  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.  
  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
  349.