home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / gnus / gnus-virt.el < prev    next >
Encoding:
Text File  |  1995-03-25  |  10.9 KB  |  287 lines
  1. ;;; gnus-virt.el --- framework for "virtual" newsgroups
  2.  
  3. ;; Copyright (C) 1993, 1994 Jamie Zawinski <jwz@lucid.com>
  4.  
  5. ;; This file is part of XEmacs.
  6.  
  7. ;; XEmacs is free software; you can redistribute it and/or modify it
  8. ;; 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. ;; XEmacs is distributed in the hope that it will be useful, but
  13. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. ;; General Public License for more details.
  16.  
  17. ;; You should have received a copy of the GNU General Public License
  18. ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  19. ;; 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 (and (numberp id) 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.  
  58. (defun gnus-virt-cleanup ()
  59.   (setq gnus-virt-message-numbers nil))
  60.  
  61. (add-hook 'gnus-exit-group-hook 'gnus-virt-cleanup)
  62.  
  63.  
  64. (defun gnus-virt-canonicalize-message-id (id)
  65.   "C-News has screwy notions about case sensitivity."
  66.   (if (string-match "@[^@]+\\'" id)
  67.       (concat (substring id 0 (match-beginning 0))
  68.           (downcase (substring id (match-beginning 0))))
  69.     id))
  70.  
  71. (defun gnus-virt-retrieve-headers (sequence)
  72.   "Return list of article headers specified by SEQUENCE of article id.
  73. The article ids may be message-id strings, or conses of the form
  74.   (\"newsgroup-name\" . \"article-number\").
  75. The format of the returned list is
  76.  `([NUMBER SUBJECT FROM XREF LINES DATE MESSAGE-ID REFERENCES] ...)'.
  77. If there is no References: field, In-Reply-To: field is used instead.
  78. Reader macros for the vector are defined as `nntp-header-FIELD'.
  79. Writer macros for the vector are defined as `nntp-set-header-FIELD'."
  80.   (setq gnus-virt-message-numbers (apply 'vector sequence))
  81.   (let* ((nmessages (length gnus-virt-message-numbers))
  82.      (i 0)
  83.      (last-group nil)
  84.      (rest sequence)
  85.      (per-group-queue nil)
  86.      (mid nil)
  87.      (messages (make-vector nmessages nil))
  88.      ;; local function to snarf the headers from what's on
  89.      ;; per-group-queue and slightly munge the result.
  90.      (grab-headers
  91.       (function
  92.        (lambda ()
  93.          (if last-group (gnus-request-group last-group))
  94.          (setq per-group-queue (nreverse per-group-queue))
  95.          (let* ((new (gnus-retrieve-headers-by-id per-group-queue))
  96.             (new-rest new)
  97.             (ids-rest per-group-queue)
  98.             )
  99.            (while new-rest
  100.          ;; Find the appropriate slot in `messages' for this message.
  101.          ;; Note that message-IDs are not completely case insensitive!
  102.          ;; The NNTP server downcases the part after the "@" in the
  103.          ;; message ID on the "221" reply line, but doesn't touch the
  104.          ;; Message-ID: field in the headers, so the two don't match.
  105.          (while (not (equal (gnus-virt-canonicalize-message-id
  106.                      (aref gnus-virt-message-numbers i))
  107.                     (gnus-virt-canonicalize-message-id
  108.                      (nntp-header-id (car new-rest)))))
  109.            (setq i (1+ i))
  110.            (if (>= i nmessages)
  111.                (error "couldn't find %s"
  112.                   (nntp-header-id (car new-rest))))
  113.            )
  114.          (aset messages i (car new-rest))
  115.  
  116.          ;; For newgroup/number pairs, add an entry to the Xref field
  117.          ;; if there's nothing there already (meaning it was a single
  118.          ;; post and not a crosspost.)  Since we'll be reading this in
  119.          ;; a virtual group, all posts are corossposts as far as GNUS
  120.          ;; is concerned.
  121.          (or (nntp-header-xref (car new-rest))
  122.              (nntp-set-header-xref
  123.               (car new-rest)
  124.               (concat (system-name) " " last-group ":"
  125.                   (nntp-header-number (car new-rest)))))
  126.          ;; NNTP HEAD command run on message-ids returns 0 as message
  127.          ;; number; so store some unique number there, and store the
  128.          ;; the message descriptor in a variable.  (We don't just
  129.          ;; store the descriptor in the header because things expect
  130.          ;; it to be numeric, dammit...)
  131.          (nntp-set-header-number (car new-rest) i)
  132.          ;; Possibly replace conses of (group . n) with message-ids.
  133.          (aset gnus-virt-message-numbers i
  134.                (nntp-header-id (car new-rest)))
  135.          (setq ids-rest (cdr ids-rest)
  136.                new-rest (cdr new-rest)))
  137.            )
  138.          (setq last-group nil
  139.            per-group-queue nil)))))
  140.     (while rest
  141.       (setq mid (car rest))
  142.        (cond ((consp mid)        ; newsgroup/article-number pair
  143.          (if (equal last-group (car mid))
  144.          ;; the queue has other article-numbers in this group; add.
  145.          (setq per-group-queue (cons (cdr mid) per-group-queue))
  146.            ;; else the queue has article-numbers in another group, or
  147.            ;; it has raw message-ids.  Flush the queue, and restart it.
  148.            (if per-group-queue (funcall grab-headers))
  149.            (setq last-group (car mid)
  150.              per-group-queue (cons (cdr mid) nil))))
  151.  
  152.         (t                ; message-id
  153.          (if last-group
  154.          ;; the queue has article-numbers of some group on it;
  155.          ;; flush and restart it.
  156.          (funcall grab-headers))
  157.          ;; in this case the queue has message-ids (in no group.)
  158.          (setq per-group-queue (cons mid per-group-queue))))
  159.       (setq rest (cdr rest)))
  160.     ;;
  161.     ;; at the end, if there is still stuff on the queue, flush it.
  162.     (if per-group-queue (funcall grab-headers))
  163.     ;;
  164.     ;; Now notice messages we weren't able to get (why?) and flag them.
  165.     (setq i 0)
  166.     (while (< i nmessages)
  167.       (if (null (aref messages i))
  168.       (let ((id (format "%s" (aref gnus-virt-message-numbers i))))
  169.         (aset messages i
  170.           (vector i id "EXPIRED?" nil 0 "" id nil))))
  171.       (setq i (1+ i)))
  172.     (append messages nil) ; coerce vector to list
  173.     ))
  174.  
  175. (defun gnus-virt-select-newsgroup (name message-ids)
  176.   "Select a \"virtual\" newsgroup consisting of the given message-ids.
  177. The message ids may be actual message-id strings, or conses of the form
  178.   (\"newsgroup-name\" . \"article-number\")."
  179.   ;; much of this copied from gnus-select-newsgroup
  180.   (gnus-start-news-server)
  181.   (setq gnus-newsgroup-name name)
  182. ;;  (setq gnus-newsgroup-unreads ...)
  183.   (setq gnus-newsgroup-unselected nil)
  184.  
  185.   ;; Get headers list.
  186.   (setq gnus-newsgroup-headers (gnus-virt-retrieve-headers message-ids))
  187.  
  188.   (setq gnus-newsgroup-unreads
  189.     (mapcar 'gnus-header-number gnus-newsgroup-headers))
  190.  
  191.   ;; ## do something about expired articles here?
  192.   ;; ## do something about marked articles here?
  193.  
  194.   ;; First and last article in this newsgroup.
  195.   (setq gnus-newsgroup-begin
  196.     (if gnus-newsgroup-headers
  197.         (nntp-header-number (car gnus-newsgroup-headers))
  198.       0
  199.       ))
  200.   (setq gnus-newsgroup-end
  201.     (if gnus-newsgroup-headers
  202.         (nntp-header-number
  203.          (gnus-last-element gnus-newsgroup-headers))
  204.       0
  205.       ))
  206.   ;; File name that an article was saved last.
  207.   (setq gnus-newsgroup-last-rmail nil)
  208.   (setq gnus-newsgroup-last-mail nil)
  209.   (setq gnus-newsgroup-last-folder nil)
  210.   (setq gnus-newsgroup-last-file nil)
  211.   ;; Reset article pointer etc.
  212.   (setq gnus-current-article nil)
  213.   (setq gnus-current-headers nil)
  214.   (setq gnus-current-history nil)
  215.   (setq gnus-have-all-headers nil)
  216.   (setq gnus-last-article nil)
  217.   ;; Clear old hash tables for the variable gnus-newsgroup-headers.
  218.   (gnus-clear-hashtables-for-newsgroup-headers)
  219.   ;; GROUP is successfully selected.
  220.   t
  221.   )
  222.  
  223. (defun gnus-virt-summary-read-group (group message-ids &optional no-article)
  224.   "Start reading news in a \"virtual\" newsgroup of the given message-ids.
  225. The message ids may be actual message-id strings, or conses of the form
  226.   (\"newsgroup-name\" . \"article-number\").
  227. If NO-ARTICLE is non-nil, no article is selected initially."
  228.  
  229.   (setq message-ids (mapcar 'gnus-virt-canonicalize-message-id message-ids))
  230.  
  231.   ;; delete duplicate message ids
  232.   (let ((rest message-ids))
  233.     (while rest
  234.       (if (member (car rest) (cdr rest))
  235.       (setcar rest nil))
  236.       (setq rest (cdr rest)))
  237.     (setq message-ids (delq nil message-ids)))
  238.  
  239.   ;; make there be a newsgroup to prevent error when quitting...
  240.   (or (gnus-gethash group gnus-newsrc-hashtb)
  241.       (gnus-sethash group (list group nil) gnus-newsrc-hashtb))
  242.  
  243.   ;; this is a real kludge; we need to cause gnus-virt-select-newsgroup to
  244.   ;; be called instead of gnus-select-newsgroup so we temporarily redefine
  245.   ;; it...  We could do this by advising gnus-select-newsgroup and using
  246.   ;; some special bindings for communication, but that's not really much
  247.   ;; less gross than this.
  248.   (let ((old (symbol-function 'gnus-select-newsgroup)))
  249.     (unwind-protect
  250.     (progn
  251.       (fset 'gnus-select-newsgroup
  252.         (function (lambda (group show-all)
  253.                 (gnus-virt-select-newsgroup group message-ids))))
  254.       (gnus-summary-read-group group nil no-article))
  255.       ;; protected
  256.       (fset 'gnus-select-newsgroup old))))
  257.  
  258. ;;; A simple user-level interface; this could be greatly improved.
  259. ;;; In fact, doing that is what all of the interesting problems here
  260. ;;; are about.
  261.  
  262. (defun gnus-virt-read-merged-groups (virtual-name newsgroup-names
  263.                      &optional all no-article)
  264.   "Read news in the given newsgroup as if they were one group.
  265. VIRTUAL-NAME is the name to assign to this new group;
  266. NEWSGROUP-NAMES is a list of the names of the newsgroups to combine.
  267. If argument ALL is non-nil, already read articles become readable.
  268. If optional argument NO-ARTICLE is non-nil, no article body is displayed."
  269.   (let ((articles nil)
  270.     (rest (reverse newsgroup-names)))
  271.     (while rest
  272.       (let* ((group (car rest))
  273.          (numbers (gnus-uncompress-sequence
  274.                (nthcdr 2 (gnus-gethash group
  275.                            (if all
  276.                            gnus-active-hashtb
  277.                          gnus-unread-hashtb))))))
  278.     (setq articles (nconc (mapcar '(lambda (x) (cons group x)) numbers)
  279.                   articles)))
  280.       (setq rest (cdr rest)))
  281.     ;; ## We should compute gnus-newsgroup-unreads and gnus-newsgroup-marked
  282.     ;;    as the union of the unread/marked articles of all of these groups.
  283.     (gnus-virt-summary-read-group virtual-name articles no-article)))
  284.  
  285.  
  286. (provide 'gnus-virt)
  287.