Function: gnus-uu-save-article

gnus-uu-save-article is a byte-compiled function defined in gnus-uu.el.gz.

Signature

(gnus-uu-save-article BUFFER IN-STATE)

Source Code

;; Defined in /usr/src/emacs/lisp/gnus/gnus-uu.el.gz
;; Functions for saving and possibly digesting articles without
;; any decoding.

;; Function called by gnus-uu-grab-articles to treat each article.
(defun gnus-uu-save-article (buffer in-state)
  (cond
   (gnus-uu-save-separate-articles
    (with-current-buffer buffer
      (let ((coding-system-for-write mm-text-coding-system))
	(gnus-write-buffer
	 (concat gnus-uu-saved-article-name gnus-current-article)))
      (cond ((eq in-state 'first) (list gnus-uu-saved-article-name 'begin))
	    ((eq in-state 'first-and-last) (list gnus-uu-saved-article-name
						 'begin 'end))
	    ((eq in-state 'last) (list 'end))
	    (t (list 'middle)))))
   ((not gnus-uu-save-in-digest)
    (with-current-buffer buffer
      (write-region (point-min) (point-max) gnus-uu-saved-article-name t)
      (cond ((eq in-state 'first) (list gnus-uu-saved-article-name 'begin))
	    ((eq in-state 'first-and-last) (list gnus-uu-saved-article-name
						 'begin 'end))
	    ((eq in-state 'last) (list 'end))
	    (t (list 'middle)))))
   (t
    (let ((header (gnus-summary-article-header)))
      (push (cons (mail-header-from header)
		  (mail-header-subject header))
	    gnus-uu-digest-from-subject))
    (let ((name (file-name-nondirectory gnus-uu-saved-article-name))
	  beg subj headers headline sorthead body end-string state)
      (if (or (eq in-state 'first)
	      (eq in-state 'first-and-last))
	  (progn
	    (setq state (list 'begin))
	    (with-current-buffer (gnus-get-buffer-create "*gnus-uu-body*")
	      (erase-buffer))
	    (with-current-buffer (gnus-get-buffer-create "*gnus-uu-pre*")
	      (erase-buffer)
	      (insert (format
		       "Date: %s\nFrom: %s\nSubject: %s Digest\n\n"
		       (message-make-date) name name))
	      (when (and message-forward-as-mime gnus-uu-digest-buffer)
		(insert
		 "<#mml type=message/rfc822>\nSubject: Topics\n\n<#/mml>\n")
		(forward-line -1))
	      (insert "Topics:\n")))
	(when (not (eq in-state 'end))
	  (setq state (list 'middle))))
      (with-current-buffer "*gnus-uu-body*"
	(goto-char (setq beg (point-max)))
	(with-current-buffer buffer
	  (save-restriction
	    (let ((inhibit-read-only t))
	      (set-text-properties (point-min) (point-max) nil))
	    (when (and message-forward-as-mime
		       message-forward-show-mml
		       gnus-uu-digest-buffer)
	      (mm-enable-multibyte)
	      (mime-to-mml))
	    (goto-char (point-min))
	    (search-forward "\n\n")
	    (unless (and message-forward-as-mime gnus-uu-digest-buffer)
	      ;; Quote all 30-dash lines.
	      (save-excursion
		(while (re-search-forward "^-" nil t)
		  (beginning-of-line)
		  (delete-char 1)
		  (insert "- "))))
	    (setq body (buffer-substring (1- (point)) (point-max)))
	    (narrow-to-region (point-min) (point))
	    (if (not (setq headers gnus-uu-digest-headers))
		(setq sorthead (buffer-string))
	      (while headers
		(setq headline (car headers))
		(setq headers (cdr headers))
		(goto-char (point-min))
		(while (re-search-forward headline nil t)
		  (setq sorthead
			(concat sorthead
				(buffer-substring
				 (match-beginning 0)
				 (or (and (re-search-forward "^[^ \t]" nil t)
					  (1- (point)))
				     (progn (forward-line 1) (point)))))))))))
	(if (and message-forward-as-mime gnus-uu-digest-buffer)
	  (if message-forward-show-mml
	      (progn
		(insert "\n<#mml type=message/rfc822>\n")
		(insert sorthead) (goto-char (point-max))
		(insert body) (goto-char (point-max))
		(insert "\n<#/mml>\n"))
	    (let ((buf (mml-generate-new-buffer " *mml*")))
	      (with-current-buffer buf
		(insert sorthead)
		(goto-char (point-min))
		(when (re-search-forward "^Subject: \\(.*\\)$" nil t)
		  (setq subj (buffer-substring (match-beginning 1)
					       (match-end 1))))
		(goto-char (point-max))
		(insert body))
	      (insert "\n<#part type=message/rfc822"
		      " buffer=\"" (buffer-name buf) "\">\n")))
	  (insert sorthead) (goto-char (point-max))
	  (insert body) (goto-char (point-max))
	  (insert (concat "\n" (make-string 30 ?-) "\n\n")))
	(goto-char beg)
	(when (re-search-forward "^Subject: \\(.*\\)$" nil t)
	  (setq subj (buffer-substring (match-beginning 1) (match-end 1))))
	(when subj
	  (with-current-buffer "*gnus-uu-pre*"
	    (insert (format "   %s\n" subj)))))
      (when (or (eq in-state 'last)
		(eq in-state 'first-and-last))
	(if (and message-forward-as-mime gnus-uu-digest-buffer)
	    (with-current-buffer gnus-uu-digest-buffer
	      (erase-buffer)
	      (insert-buffer-substring "*gnus-uu-pre*")
	      (goto-char (point-max))
	      (insert-buffer-substring "*gnus-uu-body*"))
	  (with-current-buffer "*gnus-uu-pre*"
	    (insert (format "\n\n%s\n\n" (make-string 70 ?-)))
	    (if gnus-uu-digest-buffer
		(with-current-buffer gnus-uu-digest-buffer
		  (erase-buffer)
		  (insert-buffer-substring "*gnus-uu-pre*"))
	      (let ((coding-system-for-write mm-text-coding-system))
		(gnus-write-buffer gnus-uu-saved-article-name))))
	  (with-current-buffer "*gnus-uu-body*"
	    (goto-char (point-max))
	    (insert
	     (concat (setq end-string (format "End of %s Digest" name))
		     "\n"))
	    (insert (concat (make-string (length end-string) ?*) "\n"))
	    (if gnus-uu-digest-buffer
		(with-current-buffer gnus-uu-digest-buffer
		  (goto-char (point-max))
		  (insert-buffer-substring "*gnus-uu-body*"))
	      (let ((coding-system-for-write mm-text-coding-system)
		    (file-name-coding-system nnmail-pathname-coding-system))
		(write-region
		 (point-min) (point-max) gnus-uu-saved-article-name t)))))
	(gnus-kill-buffer "*gnus-uu-pre*")
	(gnus-kill-buffer "*gnus-uu-body*")
	(push 'end state))
      (if (memq 'begin state)
	  (cons gnus-uu-saved-article-name state)
	state)))))