home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / gnu / lucid / lemacs-19.6 / lisp / gnus / gnus-digest.el < prev    next >
Encoding:
Text File  |  1992-12-28  |  16.4 KB  |  429 lines
  1. ;;; Undigestification commands for GNUS newsreader
  2. ;; Copyright (C) 1991 Jamie Zawinski
  3. ;; This file is part of GNU Emacs.
  4.  
  5. ;; GNU Emacs is distributed in the hope that it will be useful,
  6. ;; but WITHOUT ANY WARRANTY.  No author or distributor
  7. ;; accepts responsibility to anyone for the consequences of using it
  8. ;; or for whether it serves any particular purpose or works at all,
  9. ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  10. ;; License for full details.
  11.  
  12. ;; Everyone is granted permission to copy, modify and redistribute
  13. ;; GNU Emacs, but only under the conditions described in the
  14. ;; GNU Emacs General Public License.   A copy of this license is
  15. ;; supposed to have been given to you along with GNU Emacs so you
  16. ;; can know your rights and responsibilities.  It should be in a
  17. ;; file named COPYING.  Among other things, the copyright notice
  18. ;; and this notice must be preserved on all copies.
  19.  
  20.  
  21. ;; In some newsgroups, like comp.risks, every message is a digest of
  22. ;; other messages.  
  23. ;;
  24. ;; This is stupid.  Those digests should be exploded into individual messages
  25. ;; before being inserted in the USENET stream.  There is absolutely no benefit
  26. ;; to doing it any other way.
  27. ;;
  28. ;; GNUS used to read digests by invoking RMAIL on the message in such a way
  29. ;; that it would do the undigestification.  However, this has the extremely
  30. ;; bad side-effect that you have to use the RMAIL interface instead of the
  31. ;; GNUS interface.  GNUS and RMAIL do many things differently, and it's
  32. ;; horribly distracting to have to change gears when reading certain
  33. ;; newsgroups.
  34. ;;
  35. ;; This code makes GNUS understand digests directly.  The command
  36. ;; gnus-Subject-read-digest (bound to C-d) will expand the current message
  37. ;; as a digest.  The *Subject* buffer will be replaced with lines representing
  38. ;; the messages in the digest; the normal GNUS commands will work on the 
  39. ;; sub-messages of the digest, including kill files.
  40. ;;
  41. ;; Typing \\[gnus-Subject-exit] at the *Subject* buffer will replace the list
  42. ;; of messages in the digest with the list of (digest) messages in the
  43. ;; newsgroup.  Reading a digest is something like a recursive edit.
  44. ;;
  45. ;; INSTALLATION:
  46. ;;
  47. ;; In addition to loading this file, you must apply the following patch
  48. ;; to gnus.el.  This patch was made against version 3.13:
  49. ;;
  50. ;; ------------------------------------------------------------------------
  51. ;; *** /gnuemacs/lisp/gnus.el    Thu Oct 11 06:40:32 1990
  52. ;; --- gnus.el    Sat Feb  1 23:39:04 1992
  53. ;; ***************
  54. ;; *** 3748,3751 ****
  55. ;; --- 3748,3754 ----
  56. ;;   gnus-Exit-group-hook is called with no arguments if that value is non-nil."
  57. ;;     (interactive)
  58. ;; +   (if gnus-digest-mode
  59. ;; +       (gnus-unselect-digest-article)
  60. ;; +     ;; else
  61. ;;     (let ((updated nil)
  62. ;;       (gnus-newsgroup-headers gnus-newsgroup-headers)
  63. ;; ***************
  64. ;; *** 3788,3792 ****
  65. ;;       (bury-buffer gnus-Article-buffer))
  66. ;;       (gnus-configure-windows 'ExitNewsgroup)
  67. ;; !     (pop-to-buffer gnus-Group-buffer)))
  68. ;;   
  69. ;;   (defun gnus-Subject-quit ()
  70. ;; --- 3791,3795 ----
  71. ;;       (bury-buffer gnus-Article-buffer))
  72. ;;       (gnus-configure-windows 'ExitNewsgroup)
  73. ;; !     (pop-to-buffer gnus-Group-buffer))))
  74. ;;   
  75. ;;   (defun gnus-Subject-quit ()
  76. ;; ***************
  77. ;; *** 3882,3885 ****
  78. ;; --- 3885,3890 ----
  79. ;;         ))
  80. ;;   
  81. ;; + (defvar gnus-digest-mode nil)
  82. ;; + 
  83. ;;   (defun gnus-Article-prepare (article &optional all-headers)
  84. ;;     "Prepare ARTICLE in Article mode buffer.
  85. ;; ***************
  86. ;; *** 3889,3893 ****
  87. ;;       (let ((buffer-read-only nil))
  88. ;;         (erase-buffer)
  89. ;; !       (if (gnus-request-article article)
  90. ;;         (progn
  91. ;;           ;; Prepare article buffer
  92. ;; --- 3894,3900 ----
  93. ;;       (let ((buffer-read-only nil))
  94. ;;         (erase-buffer)
  95. ;; !       (if (if gnus-digest-mode
  96. ;; !           (gnus-request-digest-article article)
  97. ;; !         (gnus-request-article article))
  98. ;;         (progn
  99. ;;           ;; Prepare article buffer
  100. ;; ***************
  101. ;; *** 4988,4991 ****
  102. ;; --- 4995,4999 ----
  103. ;;     (if (gnus-request-group group)
  104. ;;         (let ((articles nil))
  105. ;; +     (gnus-digest-reset)
  106. ;;       (setq gnus-newsgroup-name group)
  107. ;;       (setq gnus-newsgroup-unreads
  108. ;; ------------------------------------------------------------------------
  109. ;;
  110. ;; I also suggest adding some variation of this code to your .emacs file:
  111. ;;
  112. ;;   (defvar gnus-digestified-newsgroups
  113. ;;     '("comp.risks" "comp.sys.ibm.pc.digest" "comp.sys.mac.digest"
  114. ;;       "sci.psychology.digest" "soc.human-nets" "soc.politics.arms-d"))
  115. ;;   
  116. ;;   (setq gnus-Select-article-hook
  117. ;;         '(lambda ()
  118. ;;            (or gnus-digest-mode ; don't do it if we're already doing it
  119. ;;                (if (string-match (mapconcat 'regexp-quote
  120. ;;                                             gnus-digestified-newsgroups
  121. ;;                                             "\\|")
  122. ;;                                  gnus-newsgroup-name)
  123. ;;                    (gnus-Subject-read-digest)))))
  124. ;;
  125. ;; IMPLEMENTATION:
  126. ;;
  127. ;;   Selecting a message as a digest copies the message to a temporary buffer,
  128. ;;   and parses it into sub-messages.  The message-serperators are removed,
  129. ;;   and dummy "Newsgroups" and "Message-ID" fields are inserted for each
  130. ;;   sub-message (so that followups and message-yanking works).  The variable
  131. ;;   gnus-newsgroup-headers is set to a vector of nntp-header structures
  132. ;;   corresponding to the sub-messages.  This makes the normal Subject-buffer
  133. ;;   generation (and commands) work.  The article-number of each of these
  134. ;;   new message descriptors is the buffer-index of the message in the 
  135. ;;   temporary buffer.  When GNUS is in digest-mode, gnus-Article-prepare
  136. ;;   will take the messages out of this buffer instead of calling 
  137. ;;   gnus-request-article.
  138. ;;
  139. ;;   Exiting a digest restores gnus-newsgroup-headers and related variables
  140. ;;   to their previous values, representing the newsgroup itself instead of
  141. ;;   the messages in one article of the newsgroup.
  142. ;;
  143. ;; TODO:
  144. ;;
  145. ;;   o  The `gnus-auto-select-next' functionality is disabled when reading
  146. ;;      a digest.  When you attempt to select the next message and there
  147. ;;      are no more messages in the digest, then digest-mode should be
  148. ;;      exited and the next (real) message selected.
  149. ;;
  150. ;;   o  Instead of changing the contents of the *Subject* buffer, I think
  151. ;;      there should be a seperate buffer forthe sub-message subjects.  It
  152. ;;      should be possible to have a four window display: Newsgroup list;
  153. ;;      Subject list (the digests); Subject list (the messages in the current
  154. ;;      digest); and Article (the current message in the current digest.)
  155. ;;
  156. ;;   o  Perhaps all of the messages in a newsgroup should be undigestified
  157. ;;      at once; that way, the Subject buffer would be filled with all of
  158. ;;      the messages, instead of all of the messages of one digest, followed
  159. ;;      by the digest list, followed by the messages of the next digest, etc.
  160. ;;
  161.  
  162. (require 'gnus)
  163.  
  164. (define-key gnus-Subject-mode-map "\C-d" 'gnus-Subject-read-digest)
  165.  
  166.  
  167. (defun gnus-parse-digest-1 ()
  168.   ;; The current buffer is assumed to contain a digest message.
  169.   ;; This function returns a list of buffer-points (integers) which
  170.   ;; are the starting points of the digestified sub-articles.
  171.   ;; The buffer is modified, to remove the message-seperators, and to
  172.   ;; insert fake Newsgroup: and Message-ID: headers for the sub-messages.
  173.   ;; This doesn't do RFC-934 digests because comp.risks isn't one of them.
  174.   (goto-char (point-min))
  175.   (let ((case-fold-search t)
  176.     newsgroups-header
  177.     subject-header
  178.     (message-id-tick 1)
  179.     p)
  180.     (search-forward "\n\n")
  181.     (setq p (point))
  182.     (save-restriction
  183.       (narrow-to-region (point-min) p)
  184.       (setq newsgroups-header (or (mail-fetch-field "Newsgroups")
  185.                   gnus-newsgroup-name)
  186.         subject-header (or (mail-fetch-field "Subject")
  187.                    (concat gnus-newsgroup-name " digest"))))
  188.     (goto-char (point-max))
  189.     (skip-chars-backward " \t\n")
  190.     ;; What a repulsive hack this is...
  191.     (forward-line -10)
  192.     (if (re-search-forward "^End of.*Digest.*\n" nil t)
  193.     (delete-region (match-beginning 0) (point-max)))
  194.     (goto-char p)
  195.     (let ((result (list (point-min))))
  196.       (while (re-search-forward "^\\(---+\\|-\\)\n" nil t)
  197.     (setq p (match-beginning 0))
  198.     (skip-chars-forward "\n\r\t ")
  199.     (delete-region p (point))
  200.     (if (looking-at "[ \t\n\r]*\\'")
  201.         nil
  202.       (setq result (cons (point) result))
  203.       (insert "Newsgroups: " newsgroups-header "\n")
  204.       (insert "Message-ID: <" subject-header " message #"
  205.           (+ message-id-tick ?0) ">\n")
  206.       (setq message-id-tick (1+ message-id-tick))
  207.       ))
  208.       ;;(if (eq (car result) (point-max)) (setq result (cdr result)))
  209.       (nreverse result))))
  210.  
  211. (defvar gnus-digest-divisions) ; buffer-local in the digest source buffer
  212.  
  213. (defun gnus-parse-digest ()
  214.   ;; workalike for nntp-retrieve-headers: returns a list of the form
  215.   ;;  ([NUMBER SUBJECT FROM XREF LINES DATE MESSAGE-ID REFERENCES] ...)
  216.   ;; for the sub-articles of a digest.  The number is the buffer-point
  217.   ;; of the sub-message, rather than an NNTP message id.
  218.   (let ((points (gnus-parse-digest-1))
  219.     (case-fold-search t)
  220.     (opm (point-max))
  221.     (result nil))
  222.     (make-local-variable 'gnus-digest-divisions)
  223.     (setq gnus-digest-divisions points)
  224.     (save-restriction
  225.       (while points
  226.     (let (point subject from xref lines date message-id references)
  227.       (widen)
  228.       (goto-char (setq point (car points)))
  229.       (narrow-to-region point (or (car (cdr points)) opm))
  230.       
  231.       ;; Mostly lifted from nntp-retrieve-headers: this is really
  232.       ;; inefficient.
  233.       (while (and (not (eobp))
  234.               (not (looking-at "\n"))) ; eoh
  235.         ;; Note that we accept ">From:" as well as "From:", since the
  236.         ;; boneheads who maintain comp.sys.mac.digest allow their digests
  237.         ;; to pass through some even-more-broken-than-sendmail gateway
  238.         ;; along the way, thus corrupting the From: field in every
  239.         ;; message.  Fuck me harder!
  240.         (if (looking-at "\\(>?From\\|Subject\\|Date\\|Lines\\|Xref\\|References\\|Message-ID\\):[ \t]+\\([^ \t\n]+.*\\)\r?$")
  241.         (let ((s (buffer-substring (match-beginning 2) (match-end 2)))
  242.               (c (char-after (match-beginning 0))))
  243.           ;; We don't have to worry about letter case.
  244.           (cond ((char-equal c ?F)    ;From:
  245.              (setq from s))
  246.             ((char-equal c ?>)    ;>From (gag me with a chainsaw)
  247.              (setq from s))
  248.             ((char-equal c ?S)    ;Subject:
  249.              (setq subject s))
  250.             ((char-equal c ?D)    ;Date:
  251.              (setq date s))
  252.             ((char-equal c ?L)    ;Lines:
  253.              (setq lines (string-to-int s)))
  254.             ((char-equal c ?X)    ;Xref:
  255.              (setq xref s))
  256.             ((char-equal c ?R)    ;References:
  257.              (setq references s))
  258.             ((char-equal c ?M)    ;Message-ID:
  259.              (setq message-id s))
  260.             )))
  261.         (forward-line 1))
  262.       (if (null subject) (setq subject "(None)"))
  263.       (if (null from) (setq from "(Unknown User)"))
  264.       (if (null message-id) (error "no message id?"))
  265.       (if (null lines) (setq lines (count-lines (point-min) (point-max))))
  266.       (setq result (cons (vector point subject from xref lines date
  267.                      message-id references)
  268.                  result)
  269.         points (cdr points)))))
  270.     (nreverse result)))
  271.  
  272. (defvar gnus-digest-save-state nil) ; ack pfffft.
  273. (defvar gnus-digest-buffer nil)
  274.  
  275. (defun gnus-select-digest-article ()
  276.   (if gnus-digest-save-state (error "already reading a digest"))
  277.   (gnus-Subject-select-article)
  278.   (gnus-Subject-show-all-headers)
  279.   (if (not (and gnus-digest-buffer (buffer-name gnus-digest-buffer)))
  280.       (setq gnus-digest-buffer (get-buffer-create " *gnus-digest-buffer*")))
  281.   (save-excursion
  282.     (set-buffer gnus-digest-buffer)
  283.     (erase-buffer)
  284.     ;; this contortion is because insert-buffer-contents can't be made
  285.     ;; to grab text outside of the narrowed region.
  286.     (save-excursion
  287.       (save-restriction
  288.     (set-buffer gnus-Article-buffer)
  289.     (widen)
  290.     (save-excursion
  291.       (set-buffer gnus-digest-buffer)
  292.       (insert-buffer gnus-Article-buffer))))
  293.     (let ((header-data (gnus-parse-digest)))
  294.       ;; I wish we didn't have to restore all of this crap, but we do...
  295.       (setq gnus-digest-save-state (list gnus-newsgroup-unreads
  296.                      gnus-newsgroup-marked
  297.                      gnus-newsgroup-begin
  298.                      gnus-newsgroup-headers
  299.                      gnus-auto-select-next
  300.                      (save-excursion
  301.                        (set-buffer gnus-Subject-buffer)
  302.                        (point))
  303.                      ))
  304.       (setq gnus-newsgroup-unreads
  305.           (mapcar (function (lambda (x) (nntp-header-number x)))
  306.               header-data)
  307.         gnus-newsgroup-marked nil
  308.         gnus-newsgroup-begin (car gnus-newsgroup-unreads)
  309.         gnus-newsgroup-end (gnus-last-element gnus-newsgroup-unreads)
  310.         gnus-newsgroup-headers header-data
  311.         gnus-auto-select-next nil  ; oh, foo.
  312.         )
  313.       ;; Reset article pointer etc.
  314.       (setq gnus-current-article nil)
  315.       (setq gnus-current-headers nil)
  316.       (setq gnus-current-history nil)
  317.       (setq gnus-have-all-headers nil)
  318.       (setq gnus-last-article nil)
  319.       )))
  320.  
  321.  
  322. (defun gnus-digest-reset ()
  323.   (let (p)
  324.     (if gnus-digest-save-state
  325.     (setq gnus-newsgroup-unreads (nth 0 gnus-digest-save-state)
  326.           gnus-newsgroup-marked  (nth 1 gnus-digest-save-state)
  327.           gnus-newsgroup-begin   (nth 2 gnus-digest-save-state)
  328.           gnus-newsgroup-headers (nth 3 gnus-digest-save-state)
  329.           gnus-auto-select-next  (nth 4 gnus-digest-save-state)
  330.           p (nth 5 gnus-digest-save-state)
  331.           gnus-digest-save-state nil
  332.           gnus-digest-mode nil))
  333.     p))
  334.  
  335.  
  336. (defun gnus-unselect-digest-article ()
  337.   (if (not gnus-digest-save-state) (error "not reading a digest"))
  338.   (let ((p (gnus-digest-reset)))
  339.     (gnus-Subject-exit t)
  340.     ;; We have to adjust the point of Group mode buffer because the current
  341.     ;; point was moved to the next unread newsgroup by exiting.
  342.     (gnus-Subject-jump-to-group gnus-newsgroup-name)
  343.     
  344.     (gnus-Subject-setup-buffer)
  345.     (run-hooks 'gnus-Select-group-hook)
  346.     (gnus-Subject-prepare)
  347.     (goto-char p)))
  348.  
  349.  
  350. (defvar inside-select-digest nil) ; hands off
  351.  
  352. (defun gnus-Subject-read-digest ()
  353.   "Read the current message as a digest.
  354. The *Subject* buffer will be replaced with lines representing the messages
  355. in the digest; the normal GNUS commands will work on the sub-messages of
  356. the digest.  Typing \\[gnus-Subject-exit] at the *Subject* buffer will 
  357. replace the list of messages in the digest with the list of (digest) 
  358. messages in the newsgroup.  Reading a digest is something like a recursive
  359. edit."
  360.   (interactive)
  361.   (if inside-select-digest
  362.       nil
  363.     (let ((inside-select-digest t))
  364.   ;; most of this is copied from gnus-Subject-read-group.
  365.   (gnus-select-digest-article)
  366.   (gnus-Subject-setup-buffer)
  367.   (run-hooks 'gnus-Select-group-hook)
  368.   (gnus-Subject-prepare)
  369.   (run-hooks 'gnus-Apply-kill-hook)
  370.   (if (zerop (buffer-size)) (error "empty digest?"))
  371.   (setq gnus-digest-mode t)
  372.   ;; Hide conversation thread subtrees.  We cannot do this in
  373.   ;; gnus-Subject-prepare-hook since kill processing may not
  374.   ;; work with hidden articles.
  375.   ;; ## Do any digest-groups include References: fields in the submessages?
  376.   ;; ## I think not, but if they do, threading should work.
  377.   (and gnus-show-threads
  378.        gnus-thread-hide-subtree
  379.        (gnus-Subject-hide-all-threads))
  380.   ;; Show first unread article if requested.
  381.   (goto-char (point-min))
  382.   (if (and gnus-auto-select-first
  383.        (gnus-Subject-first-unread-article))
  384.       ;; Window is configured automatically.
  385.       ;; Current buffer may be changed as a result of hook
  386.       ;; evaluation, especially by gnus-Subject-rmail-digest
  387.       ;; command, so we should adjust cursor point carefully.
  388.       (if (eq (current-buffer) (get-buffer gnus-Subject-buffer))
  389.       (progn
  390.         ;; Adjust cursor point.
  391.         (beginning-of-line)
  392.         (search-forward ":" nil t)))
  393.     (gnus-configure-windows 'SelectNewsgroup)
  394.     (gnus-pop-to-buffer gnus-Subject-buffer)
  395.     (gnus-Subject-set-mode-line)
  396.     ;; I sometime get confused with the old Article buffer.
  397.     (if (get-buffer gnus-Article-buffer)
  398.     (if (get-buffer-window gnus-Article-buffer)
  399.         (save-excursion
  400.           (set-buffer gnus-Article-buffer)
  401.           (let ((buffer-read-only nil))
  402.         (erase-buffer)))
  403.       (kill-buffer gnus-Article-buffer)))
  404.     ;; Adjust cursor point.
  405.     (beginning-of-line)
  406.     (search-forward ":" nil t))
  407.   )))
  408.  
  409. (defun gnus-request-digest-article (article)
  410.   ;; article is the article-number of the message, which in this case,
  411.   ;; is a buffer-index into gnus-digest-buffer of the beginning of the
  412.   ;; message.
  413.   (save-excursion
  414.     (set-buffer gnus-digest-buffer)
  415.     (let ((rest gnus-digest-divisions)
  416.       next)
  417.       (while (and rest (not next))
  418.     (if (= (car rest) article)
  419.         (setq next (or (car (cdr rest)) (buffer-size))))
  420.     (setq rest (cdr rest)))
  421.       (or next (error "no digest data for %s" article))
  422.       (goto-char next)
  423.       (set-buffer nntp-server-buffer)
  424.       (erase-buffer)
  425.       (insert-buffer-substring gnus-digest-buffer article next)
  426.       t)))
  427.  
  428. (provide 'gnus-digest)
  429.