;;; Undigestification commands for GNUS newsreader
;; Copyright (C) 1991 Jamie Zawinski
;; This file is part of GNU Emacs.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY.  No author or distributor
;; accepts responsibility to anyone for the consequences of using it
;; or for whether it serves any particular purpose or works at all,
;; unless he says so in writing.  Refer to the GNU Emacs General Public
;; License for full details.

;; Everyone is granted permission to copy, modify and redistribute
;; GNU Emacs, but only under the conditions described in the
;; GNU Emacs General Public License.   A copy of this license is
;; supposed to have been given to you along with GNU Emacs so you
;; can know your rights and responsibilities.  It should be in a
;; file named COPYING.  Among other things, the copyright notice
;; and this notice must be preserved on all copies.


;; In some newsgroups, like comp.risks, every message is a digest of
;; other messages.  
;;
;; This is stupid.  Those digests should be exploded into individual messages
;; before being inserted in the USENET stream.  There is absolutely no benefit
;; to doing it any other way.
;;
;; GNUS used to read digests by invoking RMAIL on the message in such a way
;; that it would do the undigestification.  However, this has the extremely
;; bad side-effect that you have to use the RMAIL interface instead of the
;; GNUS interface.  GNUS and RMAIL do many things differently, and it's
;; horribly distracting to have to change gears when reading certain
;; newsgroups.
;;
;; This code makes GNUS understand digests directly.  The command
;; gnus-summary-read-digest (bound to C-d) will expand the current message
;; as a digest.  The *Subject* buffer will be replaced with lines representing
;; the messages in the digest; the normal GNUS commands will work on the 
;; sub-messages of the digest, including kill files.
;;
;; Typing \\[gnus-summary-exit] at the *Subject* buffer will replace the list
;; of messages in the digest with the list of (digest) messages in the
;; newsgroup.  Reading a digest is something like a recursive edit.
;;
;; INSTALLATION:
;;
;; In addition to loading this file, you must apply the following patch
;; to gnus.el.  This patch was made against version 3.13:
;;
;; ------------------------------------------------------------------------
;; *** /gnuemacs/lisp/gnus.el	Thu Oct 11 06:40:32 1990
;; --- gnus.el	Sat Feb  1 23:39:04 1992
;; ***************
;; *** 3748,3751 ****
;; --- 3748,3754 ----
;;   gnus-exit-group-hook is called with no arguments if that value is non-nil."
;;     (interactive)
;; +   (if gnus-digest-mode
;; +       (gnus-unselect-digest-article)
;; +     ;; else
;;     (let ((updated nil)
;;   	(gnus-newsgroup-headers gnus-newsgroup-headers)
;; ***************
;; *** 3788,3792 ****
;;   	(bury-buffer gnus-article-buffer))
;;       (gnus-configure-windows 'newsgroups)
;; !     (pop-to-buffer gnus-group-buffer)))
;;   
;;   (defun gnus-summary-quit ()
;; --- 3791,3795 ----
;;   	(bury-buffer gnus-article-buffer))
;;       (gnus-configure-windows 'newsgroups)
;; !     (pop-to-buffer gnus-group-buffer))))
;;   
;;   (defun gnus-summary-quit ()
;; ***************
;; *** 3882,3885 ****
;; --- 3885,3890 ----
;;         ))
;;   
;; + (defvar gnus-digest-mode nil)
;; + 
;;   (defun gnus-article-prepare (article &optional all-headers)
;;     "Prepare ARTICLE in Article mode buffer.
;; ***************
;; *** 3889,3893 ****
;;       (let ((buffer-read-only nil))
;;         (erase-buffer)
;; !       (if (gnus-request-article article)
;;   	  (progn
;;   	    ;; Prepare article buffer
;; --- 3894,3900 ----
;;       (let ((buffer-read-only nil))
;;         (erase-buffer)
;; !       (if (if gnus-digest-mode
;; ! 	      (gnus-request-digest-article article)
;; ! 	    (gnus-request-article article))
;;   	  (progn
;;   	    ;; Prepare article buffer
;; ***************
;; *** 4988,4991 ****
;; --- 4995,4999 ----
;;     (if (gnus-request-group group)
;;         (let ((articles nil))
;; + 	(gnus-digest-reset)
;;   	(setq gnus-newsgroup-name group)
;;   	(setq gnus-newsgroup-unreads
;; ------------------------------------------------------------------------
;;
;; I also suggest adding some variation of this code to your .emacs file:
;;
;;   (defvar gnus-digestified-newsgroups
;;     '("comp.risks" "comp.sys.ibm.pc.digest" "comp.sys.mac.digest"
;;       "sci.psychology.digest" "soc.human-nets" "soc.politics.arms-d"))
;;   
;;   (setq gnus-select-article-hook
;;         '(lambda ()
;;            (or gnus-digest-mode ; don't do it if we're already doing it
;;                (if (string-match (mapconcat 'regexp-quote
;;                                             gnus-digestified-newsgroups
;;                                             "\\|")
;;                                  gnus-newsgroup-name)
;;                    (gnus-summary-read-digest)))))
;;
;; IMPLEMENTATION:
;;
;;   Selecting a message as a digest copies the message to a temporary buffer,
;;   and parses it into sub-messages.  The message-separators are removed,
;;   and dummy "Newsgroups" and "Message-ID" fields are inserted for each
;;   sub-message (so that followups and message-yanking works).  The variable
;;   gnus-newsgroup-headers is set to a vector of nntp-header structures
;;   corresponding to the sub-messages.  This makes the normal Subject-buffer
;;   generation (and commands) work.  The article-number of each of these
;;   new message descriptors is the buffer-index of the message in the 
;;   temporary buffer.  When GNUS is in digest-mode, gnus-article-prepare
;;   will take the messages out of this buffer instead of calling 
;;   gnus-request-article.
;;
;;   Exiting a digest restores gnus-newsgroup-headers and related variables
;;   to their previous values, representing the newsgroup itself instead of
;;   the messages in one article of the newsgroup.
;;
;; TODO:
;;
;;   o  The `gnus-auto-select-next' functionality is disabled when reading
;;      a digest.  When you attempt to select the next message and there
;;      are no more messages in the digest, then digest-mode should be
;;      exited and the next (real) message selected.
;;
;;   o  Instead of changing the contents of the *Subject* buffer, I think
;;      there should be a seperate buffer forthe sub-message subjects.  It
;;      should be possible to have a four window display: Newsgroup list;
;;      Subject list (the digests); Subject list (the messages in the current
;;      digest); and Article (the current message in the current digest.)
;;
;;   o  Perhaps all of the messages in a newsgroup should be undigestified
;;      at once; that way, the Subject buffer would be filled with all of
;;      the messages, instead of all of the messages of one digest, followed
;;      by the digest list, followed by the messages of the next digest, etc.
;;

(require 'gnus)

(define-key gnus-summary-mode-map "\C-d" 'gnus-summary-read-digest)


(defun gnus-parse-digest-1 ()
  ;; The current buffer is assumed to contain a digest message.
  ;; This function returns a list of buffer-points (integers) which
  ;; are the starting points of the digestified sub-articles.
  ;; The buffer is modified, to remove the message-seperators, and to
  ;; insert fake Newsgroup: and Message-ID: headers for the sub-messages.
  ;; This doesn't do RFC-934 digests because comp.risks isn't one of them.
  (goto-char (point-min))
  (let ((case-fold-search t)
	newsgroups-header
	subject-header
	(message-id-tick 1)
	p)
    (search-forward "\n\n")
    (setq p (point))
    (save-restriction
      (narrow-to-region (point-min) p)
      (setq newsgroups-header (or (mail-fetch-field "Newsgroups")
				  gnus-newsgroup-name)
	    subject-header (or (mail-fetch-field "Subject")
			       (concat gnus-newsgroup-name " digest"))))
    (goto-char (point-max))
    (skip-chars-backward " \t\n")
    ;; What a repulsive hack this is...
    (forward-line -10)
    (if (re-search-forward "^End of.*Digest.*\n" nil t)
	(delete-region (match-beginning 0) (point-max)))
    (goto-char p)
    (let ((result (list (point-min))))
      (while (re-search-forward "^\\(---+\\|-\\)\n" nil t)
	(setq p (match-beginning 0))
	(skip-chars-forward "\n\r\t ")
	(delete-region p (point))
	(if (looking-at "[ \t\n\r]*\\'")
	    nil
	  (setq result (cons (point) result))
	  (insert "Newsgroups: " newsgroups-header "\n")
	  (insert "Message-ID: <" subject-header " message #"
		  (+ message-id-tick ?0) ">\n")
	  (setq message-id-tick (1+ message-id-tick))
	  ))
      ;;(if (eq (car result) (point-max)) (setq result (cdr result)))
      (nreverse result))))

(defvar gnus-digest-divisions) ; buffer-local in the digest source buffer

(defun gnus-parse-digest ()
  ;; workalike for nntp-retrieve-headers: returns a list of the form
  ;;  ([NUMBER SUBJECT FROM XREF LINES DATE MESSAGE-ID REFERENCES] ...)
  ;; for the sub-articles of a digest.  The number is the buffer-point
  ;; of the sub-message, rather than an NNTP message id.
  (let ((points (gnus-parse-digest-1))
	(case-fold-search t)
	(opm (point-max))
	(result nil))
    (make-local-variable 'gnus-digest-divisions)
    (setq gnus-digest-divisions points)
    (save-restriction
      (while points
	(let (point subject from xref lines date message-id references)
	  (widen)
	  (goto-char (setq point (car points)))
	  (narrow-to-region point (or (car (cdr points)) opm))
	  
	  ;; Mostly lifted from nntp-retrieve-headers: this is really
	  ;; inefficient.
	  (while (and (not (eobp))
		      (not (looking-at "\n"))) ; eoh
	    ;; Note that we accept ">From:" as well as "From:", since the
	    ;; boneheads who maintain comp.sys.mac.digest allow their digests
	    ;; to pass through some even-more-broken-than-sendmail gateway
	    ;; along the way, thus corrupting the From: field in every
	    ;; message.  Fuck me harder!
	    (if (looking-at "\\(>?From\\|Subject\\|Date\\|Lines\\|Xref\\|References\\|Message-ID\\):[ \t]+\\([^ \t\n]+.*\\)\r?$")
		(let ((s (buffer-substring (match-beginning 2) (match-end 2)))
		      (c (char-after (match-beginning 0))))
		  ;; We don't have to worry about letter case.
		  (cond ((char-equal c ?F)	;From:
			 (setq from s))
			((char-equal c ?>)	;>From (gag me with a chainsaw)
			 (setq from s))
			((char-equal c ?S)	;Subject:
			 (setq subject s))
			((char-equal c ?D)	;Date:
			 (setq date s))
			((char-equal c ?L)	;Lines:
			 (setq lines (string-to-int s)))
			((char-equal c ?X)	;Xref:
			 (setq xref s))
			((char-equal c ?R)	;References:
			 (setq references s))
			((char-equal c ?M)	;Message-ID:
			 (setq message-id s))
			)))
	    (forward-line 1))
	  (if (null subject) (setq subject "(None)"))
	  (if (null from) (setq from "(Unknown User)"))
	  (if (null message-id) (error "no message id?"))
	  (if (null lines) (setq lines (count-lines (point-min) (point-max))))
	  (setq result (cons (vector point subject from xref lines date
				     message-id references)
			     result)
		points (cdr points)))))
    (nreverse result)))

(defvar gnus-digest-save-state nil) ; ack pfffft.
(defvar gnus-digest-scratch-buffer nil)

(defun gnus-select-digest-article ()
  (if gnus-digest-save-state (error "already reading a digest"))
  (gnus-summary-select-article)
  (gnus-summary-show-all-headers)
  (if (not (and gnus-digest-scratch-buffer
		(buffer-name gnus-digest-scratch-buffer)))
      (setq gnus-digest-scratch-buffer
	    (get-buffer-create " *gnus-digest-scratch-buffer*")))
  (save-excursion
    (set-buffer gnus-digest-scratch-buffer)
    (erase-buffer)
    ;; this contortion is because insert-buffer-contents can't be made
    ;; to grab text outside of the narrowed region.
    (save-excursion
      (save-restriction
	(set-buffer gnus-article-buffer)
	(widen)
	(save-excursion
	  (set-buffer gnus-digest-scratch-buffer)
	  (insert-buffer gnus-article-buffer))))
    (let ((header-data (gnus-parse-digest)))
      ;; I wish we didn't have to restore all of this crap, but we do...
      (setq gnus-digest-save-state (list gnus-newsgroup-unreads
					 gnus-newsgroup-marked
					 gnus-newsgroup-begin
					 gnus-newsgroup-headers
					 gnus-auto-select-next
					 (save-excursion
					   (set-buffer gnus-summary-buffer)
					   (point))
					 ))
      (setq gnus-newsgroup-unreads
	      (mapcar (function (lambda (x) (nntp-header-number x)))
		      header-data)
	    gnus-newsgroup-marked nil
	    gnus-newsgroup-begin (car gnus-newsgroup-unreads)
	    gnus-newsgroup-end (gnus-last-element gnus-newsgroup-unreads)
	    gnus-newsgroup-headers header-data
	    gnus-auto-select-next nil  ; oh, foo.
	    )
      ;; Reset article pointer etc.
      (setq gnus-current-article nil)
      (setq gnus-current-headers nil)
      (setq gnus-current-history nil)
      (setq gnus-have-all-headers nil)
      (setq gnus-last-article nil)
      )))


(defun gnus-digest-reset ()
  (let (p)
    (if gnus-digest-save-state
	(setq gnus-newsgroup-unreads (nth 0 gnus-digest-save-state)
	      gnus-newsgroup-marked  (nth 1 gnus-digest-save-state)
	      gnus-newsgroup-begin   (nth 2 gnus-digest-save-state)
	      gnus-newsgroup-headers (nth 3 gnus-digest-save-state)
	      gnus-auto-select-next  (nth 4 gnus-digest-save-state)
	      p (nth 5 gnus-digest-save-state)
	      gnus-digest-save-state nil
	      gnus-digest-mode nil))
    p))


(defun gnus-unselect-digest-article ()
  (if (not gnus-digest-save-state) (error "not reading a digest"))
  (let ((p (gnus-digest-reset)))
    (gnus-summary-exit t)
    ;; We have to adjust the point of Group mode buffer because the current
    ;; point was moved to the next unread newsgroup by exiting.
    (gnus-summary-jump-to-group gnus-newsgroup-name)
    
    (gnus-summary-setup-buffer)
    (run-hooks 'gnus-select-group-hook)
    (gnus-summary-prepare)
    (goto-char p)))


(defvar inside-select-digest nil) ; hands off

(defun gnus-summary-read-digest ()
  "Read the current message as a digest.
The *Subject* buffer will be replaced with lines representing the messages
in the digest; the normal GNUS commands will work on the sub-messages of
the digest.  Typing \\[gnus-summary-exit] at the *Subject* buffer will 
replace the list of messages in the digest with the list of (digest) 
messages in the newsgroup.  Reading a digest is something like a recursive
edit."
  (interactive)
  (if inside-select-digest
      nil
    (let ((inside-select-digest t))
  ;; most of this is copied from gnus-summary-read-group.
  (gnus-select-digest-article)
  (gnus-summary-setup-buffer)
  (run-hooks 'gnus-select-group-hook)
  (gnus-summary-prepare)
  (run-hooks 'gnus-apply-kill-hook)
  (if (zerop (buffer-size)) (error "empty digest?"))
  (setq gnus-digest-mode t)
  ;; Hide conversation thread subtrees.  We cannot do this in
  ;; gnus-summary-prepare-hook since kill processing may not
  ;; work with hidden articles.
  ;; ## Do any digest-groups include References: fields in the submessages?
  ;; ## I think not, but if they do, threading should work.
  (and gnus-show-threads
       gnus-thread-hide-subtree
       (gnus-summary-hide-all-threads))
  ;; Show first unread article if requested.
  (goto-char (point-min))
  (if (and gnus-auto-select-first
	   (gnus-summary-first-unread-article))
      ;; Window is configured automatically.
      ;; Current buffer may be changed as a result of hook
      ;; evaluation, especially by gnus-summary-rmail-digest
      ;; command, so we should adjust cursor point carefully.
      (if (eq (current-buffer) (get-buffer gnus-summary-buffer))
	  (progn
	    ;; Adjust cursor point.
	    (beginning-of-line)
	    (search-forward ":" nil t)))
    (gnus-configure-windows 'newsgroups)
    (gnus-pop-to-buffer gnus-summary-buffer)
    (gnus-summary-set-mode-line)
    ;; I sometime get confused with the old Article buffer.
    (if (get-buffer gnus-article-buffer)
	(if (get-buffer-window gnus-article-buffer)
	    (save-excursion
	      (set-buffer gnus-article-buffer)
	      (let ((buffer-read-only nil))
		(erase-buffer)))
	  (kill-buffer gnus-article-buffer)))
    ;; Adjust cursor point.
    (beginning-of-line)
    (search-forward ":" nil t))
  )))

(defun gnus-request-digest-article (article)
  ;; article is the article-number of the message, which in this case,
  ;; is a buffer-index into gnus-digest-scratch-buffer of the beginning of the
  ;; message.
  (save-excursion
    (set-buffer gnus-digest-scratch-buffer)
    (let ((rest gnus-digest-divisions)
	  next)
      (while (and rest (not next))
	(if (= (car rest) article)
	    (setq next (or (car (cdr rest)) (buffer-size))))
	(setq rest (cdr rest)))
      (or next (error "no digest data for %s" article))
      (goto-char next)
      (set-buffer nntp-server-buffer)
      (erase-buffer)
      (insert-buffer-substring gnus-digest-scratch-buffer article next)
      t)))

(provide 'gnus-digest)