home *** CD-ROM | disk | FTP | other *** search
/ SGI Developer Toolbox 6.1 / SGI Developer Toolbox 6.1 - Disc 4.iso / public / GNU / emacs.inst / emacs19.idb / usr / gnu / lib / emacs / site-lisp / gnus-virt.el.z / gnus-virt.el
Encoding:
Text File  |  1994-08-02  |  9.2 KB  |  237 lines
  1. ;;; gnus-virt.el --- framework for "virtual" newsgroups
  2.  
  3. ;; Copyright (C) 1993 Jamie Zawinski <jwz@lucid.com>
  4.  
  5. ;; This file is part of GNU Emacs.
  6.  
  7. ;; GNU Emacs is free software; you can redistribute it and/or modify
  8. ;; it under the terms of the GNU General Public License as published by
  9. ;; the Free Software Foundation; either version 2, or (at your option)
  10. ;; any later version.
  11.  
  12. ;; GNU Emacs is distributed in the hope that it will be useful,
  13. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15. ;; GNU General Public License for more details.
  16.  
  17. ;; You should have received a copy of the GNU General Public License
  18. ;; along with GNU Emacs; see the file COPYING.  If not, write to
  19. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21. ;; The basic idea here is this: given a set of message identifiers (either
  22. ;; message-id strings, or newsgroup/message-number pairs), display a standard
  23. ;; GNUS *Summary* buffer in which all the usual commands "just work," as if
  24. ;; all of these articles appeared in the same newsgroup (even though they
  25. ;; don't, necessarily.)
  26. ;;
  27. ;; This file does not implement the method of getting the message identifiers,
  28. ;; but it implements the substrate necessary to navigate them.
  29.  
  30. ;; This requires NNTP, because though GNUS makes it easy to define entirely
  31. ;; new access methods, it doesn't provide an easy way of subtly modifying the
  32. ;; behavior of article-access in ways that shouldn't require knowledge of the
  33. ;; underlying method.
  34.  
  35.  
  36. (require 'gnus)
  37. (require 'nntp)
  38.  
  39. (defvar gnus-virt-message-numbers nil
  40.   "A vector mapping pseudo-message-id-numbers to message-id strings
  41. or to conses of (\"newsgroup-name\" . \"article-number\").")
  42.  
  43. (or (fboundp 'gnus-virt-orig-nntp-request-article)
  44.     (fset 'gnus-virt-orig-nntp-request-article
  45.       (symbol-function 'nntp-request-article)))
  46.  
  47. (defun nntp-request-article (id)
  48.   "Select article by message ID (or number)."
  49.   (if gnus-virt-message-numbers
  50.       (setq id (aref gnus-virt-message-numbers id)))
  51.   (if (consp id)
  52.       (progn
  53.     (gnus-request-group (car id))
  54.     (setq id (cdr id))))
  55.   (gnus-virt-orig-nntp-request-article id))
  56.  
  57. (defun gnus-virt-retrieve-headers (sequence)
  58.   "Return list of article headers specified by SEQUENCE of article id.
  59. The article ids may be message-id strings, or conses of the form
  60.   (\"newsgroup-name\" . \"article-number\").
  61. The format of the returned list is
  62.  `([NUMBER SUBJECT FROM XREF LINES DATE MESSAGE-ID REFERENCES] ...)'.
  63. If there is no References: field, In-Reply-To: field is used instead.
  64. Reader macros for the vector are defined as `nntp-header-FIELD'.
  65. Writer macros for the vector are defined as `nntp-set-header-FIELD'."
  66.   (setq gnus-virt-message-numbers (make-vector (length sequence) nil))
  67.   (let* ((i 0)
  68.      (last-group nil)
  69.      (rest sequence)
  70.      (per-group-queue nil)
  71.      (mid nil)
  72.      (result nil)
  73.      ;; local function to snarf the headers from what's on
  74.      ;; per-group-queue and slightly munge the result.
  75.      (grab-headers
  76.       (function
  77.        (lambda ()
  78.          (if last-group (gnus-request-group last-group))
  79.          (setq per-group-queue (nreverse per-group-queue))
  80.          (let* ((new (gnus-retrieve-headers per-group-queue))
  81.             (new-rest new)
  82.             (ids-rest per-group-queue))
  83.            (while new-rest
  84.          ;; For newgroup/number pairs, add an entry to the Xref field
  85.          ;; if there's nothing there already (meaning it was a single
  86.          ;; post and not a crosspost.)  Since we'll be reading this in
  87.          ;; a virtual group, all posts are corossposts as far as GNUS
  88.          ;; is concerned.
  89.          (or (nntp-header-xref (car new-rest))
  90.              (nntp-set-header-xref
  91.               (car new-rest)
  92.               (concat (system-name) " " last-group ":"
  93.                   (nntp-header-number (car new-rest)))))
  94.          ;; NNTP HEAD command run on message-ids returns 0 as message
  95.          ;; number; so store some unique number there, and store the
  96.          ;; the message descriptor in a variable.  (We don't just
  97.          ;; store the descriptor in the header because things expect
  98.          ;; it to be numeric, dammit...)
  99.          (nntp-set-header-number (car new-rest) i)
  100.          (aset gnus-virt-message-numbers i
  101.                (nntp-header-id (car new-rest)))
  102.          (setq i (1+ i)
  103.                ids-rest (cdr ids-rest)
  104.                new-rest (cdr new-rest)))
  105.            (setq i (+ i (length ids-rest)))
  106.            (setq result (nconc result new)))
  107.          (setq last-group nil
  108.            per-group-queue nil)))))
  109.     (while rest
  110.       (setq mid (car rest))
  111.       (cond ((consp mid)        ; newsgroup/article-number pair
  112.          (if (equal last-group (car mid))
  113.          ;; the queue has other article-numbers in this group; add.
  114.          (setq per-group-queue (cons (cdr mid) per-group-queue))
  115.            ;; else the queue has article-numbers in another group, or
  116.            ;; it has raw message-ids.  Flush the queue, and restart it.
  117.            (if per-group-queue (funcall grab-headers))
  118.            (setq last-group (car mid)
  119.              per-group-queue (cons (cdr mid) nil))))
  120.  
  121.         (t                ; message-id
  122.          (if last-group
  123.          ;; the queue has article-numbers of some group on it;
  124.          ;; flush and restart it.
  125.          (funcall grab-headers))
  126.          ;; in this case the queue has message-ids (in no group.)
  127.          (setq per-group-queue (cons mid per-group-queue))))
  128.       (setq rest (cdr rest)))
  129.     ;; at the end, if there is still stuff on the queue, flush it.
  130.     (if per-group-queue (funcall grab-headers))
  131.     result))
  132.  
  133. (defun gnus-virt-select-newsgroup (name message-ids)
  134.   "Select a \"virtual\" newsgroup consisting of the given message-ids.
  135. The message ids may be actual message-id strings, or conses of the form
  136.   (\"newsgroup-name\" . \"article-number\")."
  137.   ;; much of this copied from gnus-select-newsgroup
  138.   (gnus-start-news-server)
  139.   (setq gnus-newsgroup-name name)
  140. ;;  (setq gnus-newsgroup-unreads ...)
  141.   (setq gnus-newsgroup-unselected nil)
  142.  
  143.   ;; Get headers list.
  144.   (setq gnus-newsgroup-headers (gnus-virt-retrieve-headers message-ids))
  145.  
  146.   (setq gnus-newsgroup-unreads
  147.     (mapcar 'gnus-header-number gnus-newsgroup-headers))
  148.  
  149.   ;; ## do something about expired articles here?
  150.   ;; ## do something about marked articles here?
  151.  
  152.   ;; First and last article in this newsgroup.
  153.   (setq gnus-newsgroup-begin
  154.     (if gnus-newsgroup-headers
  155.         (nntp-header-number (car gnus-newsgroup-headers))
  156.       0
  157.       ))
  158.   (setq gnus-newsgroup-end
  159.     (if gnus-newsgroup-headers
  160.         (nntp-header-number
  161.          (gnus-last-element gnus-newsgroup-headers))
  162.       0
  163.       ))
  164.   ;; File name that an article was saved last.
  165.   (setq gnus-newsgroup-last-rmail nil)
  166.   (setq gnus-newsgroup-last-mail nil)
  167.   (setq gnus-newsgroup-last-folder nil)
  168.   (setq gnus-newsgroup-last-file nil)
  169.   ;; Reset article pointer etc.
  170.   (setq gnus-current-article nil)
  171.   (setq gnus-current-headers nil)
  172.   (setq gnus-current-history nil)
  173.   (setq gnus-have-all-headers nil)
  174.   (setq gnus-last-article nil)
  175.   ;; Clear old hash tables for the variable gnus-newsgroup-headers.
  176.   (gnus-clear-hashtables-for-newsgroup-headers)
  177.   ;; GROUP is successfully selected.
  178.   t
  179.   )
  180.  
  181. (defun gnus-virt-summary-read-group (group message-ids &optional no-article)
  182.   "Start reading news in a \"virtual\" newsgroup of the given message-ids.
  183. The message ids may be actual message-id strings, or conses of the form
  184.   (\"newsgroup-name\" . \"article-number\").
  185. If NO-ARTICLE is non-nil, no article is selected initially."
  186.  
  187.   ;; make there be a newsgroup to prevent error when quitting...
  188.   (or (gnus-gethash group gnus-newsrc-hashtb)
  189.       (gnus-sethash group (list group nil) gnus-newsrc-hashtb))
  190.  
  191.   ;; this is a real kludge; we need to cause gnus-virt-select-newsgroup to
  192.   ;; be called instead of gnus-select-newsgroup so we temporarily redefine
  193.   ;; it...  We could do this by advising gnus-select-newsgroup and using
  194.   ;; some special bindings for communication, but that's not really much
  195.   ;; less gross than this.
  196.   (let ((old (symbol-function 'gnus-select-newsgroup)))
  197.     (unwind-protect
  198.     (progn
  199.       (fset 'gnus-select-newsgroup
  200.         (function (lambda (group show-all)
  201.                 (gnus-virt-select-newsgroup group message-ids))))
  202.       (gnus-summary-read-group group nil no-article))
  203.       ;; protected
  204.       (fset 'gnus-select-newsgroup old))))
  205.  
  206.  
  207. ;;; A simple user-level interface; this could be greatly improved.
  208. ;;; In fact, doing that is what all of the interesting problems here
  209. ;;; are about.
  210.  
  211. (defun gnus-virt-read-merged-groups (virtual-name newsgroup-names
  212.                      &optional all no-article)
  213.   "Read news in the given newsgroup as if they were one group.
  214. VIRTUAL-NAME is the name to assign to this new group;
  215. NEWSGROUP-NAMES is a list of the names of the newsgroups to combine.
  216. If argument ALL is non-nil, already read articles become readable.
  217. If optional argument NO-ARTICLE is non-nil, no article body is displayed."
  218.   (let ((articles nil)
  219.     (rest (reverse newsgroup-names)))
  220.     (while rest
  221.       (let* ((group (car rest))
  222.          (numbers (gnus-uncompress-sequence
  223.                (nthcdr 2 (gnus-gethash group
  224.                            (if all
  225.                            gnus-active-hashtb
  226.                          gnus-unread-hashtb))))))
  227.     (setq articles (nconc (mapcar '(lambda (x) (cons group x)) numbers)
  228.                   articles)))
  229.       (setq rest (cdr rest)))
  230.     ;; ## We should delete things with duplicate message-ids.
  231.     ;; ## We should compute gnus-newsgroup-unreads and gnus-newsgroup-marked
  232.     ;;    as the union of the unread/marked articles of all of these groups.
  233.     (gnus-virt-summary-read-group virtual-name articles no-article)))
  234.  
  235.  
  236. (provide 'gnus-virt)
  237.