xemacs-beta: lisp/gnus/gnus-soup.el comparison

comparison lisp/gnus/gnus-soup.el @ 108:360340f9fd5f r20-1b6

Import from CVS: tag r20-1b6

author	cvs
date	Mon, 13 Aug 2007 09:18:39 +0200
parents	0d2f883870bc
children	fe104dbd9147

comparison

equal deleted inserted replaced

-:523141596bda
+:360340f9fd5f
 	;; Find the header of the article.
 	(set-buffer gnus-summary-buffer)
 	(when (setq headers (gnus-summary-article-header (car articles)))
 	  ;; Put the article in a buffer.
 	  (set-buffer tmp-buf)
 	  (when (gnus-request-article-this-buffer
 		 (car articles) gnus-newsgroup-name)
 	    (save-restriction
 	      (message-narrow-to-head)
 	      (message-remove-header gnus-soup-ignored-headers t))
 	    (gnus-soup-store gnus-soup-directory prefix headers
 			     gnus-soup-encoding-type
 			     gnus-soup-index-type)
 	    (gnus-soup-area-set-number
 	     area (1+ (or (gnus-soup-area-number area) 0)))))
 	;; Mark article as read.
 	(set-buffer gnus-summary-buffer)
 	(gnus-summary-remove-process-mark (car articles))
 	(gnus-summary-mark-as-read (car articles) gnus-souped-mark)
 	(setq articles (cdr articles)))
 (kill-buffer tmp-buf))
 groups with \"emacs\" in the name, you could say something like:
 $ emacs -batch -f gnus-batch-brew-soup ^nnml \".*emacs.*\""
 (interactive)
 nil)
 ;;; Internal Functions:
 ;; Store the current buffer.
 (defun gnus-soup-store (directory prefix headers format index)
 ;; Create the directory, if needed.
 (gnus-make-directory directory)
 (let* ((msg-buf (nnheader-find-file-noselect
 		   (concat directory prefix ".MSG")))
 	 (idx-buf (if (= index ?n)
 		      nil
 		     (concat directory prefix ".IDX"))))
 	 (article-buf (current-buffer))
 	 from head-line beg type)
 (setq gnus-soup-buffers (cons msg-buf (delq msg-buf gnus-soup-buffers)))
 (buffer-disable-undo msg-buf)
 (when idx-buf
 (push idx-buf gnus-soup-buffers)
 (buffer-disable-undo idx-buf))
 (save-excursion
 ;; Make sure the last char in the buffer is a newline.
 (goto-char (point-max))
 	     (or (mail-fetch-field "from")
 		 (mail-fetch-field "really-from")
 		 (mail-fetch-field "sender"))))
 (goto-char (point-min))
 ;; Depending on what encoding is supposed to be used, we make
 ;; a soup header.
 (setq head-line
 	    (cond
 	     ((= gnus-soup-encoding-type ?n)
 	      (format "#! rnews %d\n" (buffer-size)))
 	     ((= gnus-soup-encoding-type ?m)
 	      (while (search-forward "\nFrom " nil t)
 		(replace-match "\n>From " t t))
 (when (or (null entry)
 	      (eq (car entry) t)
 	      (and (car entry)
 		   (> (car entry) 0))
 	      (and (not not-all)
 		   (gnus-range-length (cdr (assq 'tick (gnus-info-marks
 							(nth 2 entry)))))))
 (when (gnus-summary-read-group group nil t)
 	(setq gnus-newsgroup-processable
 	      (reverse
 	       (if (not not-all)
 	   offset
 	   (or (mail-header-subject header) "(none)")
 	   (or (mail-header-from header) "(nobody)")
 	   (or (mail-header-date header) "")
 	   (or (mail-header-id header)
 	       (concat "soup-dummy-id-"
 		       (mapconcat
 			(lambda (time) (int-to-string time))
 			(current-time) "-")))
 	   (or (mail-header-references header) "")
 	   (or (mail-header-chars header) 0)
 	   (or (mail-header-lines header) "0"))))
 			   " "))
 	 (packer (if (< (string-match "%s" packer)
 			(string-match "%d" packer))
 		     (format packer files
 			     (string-to-int (gnus-soup-unique-prefix dir)))
 		   (format packer
 			   (string-to-int (gnus-soup-unique-prefix dir))
 			   files)))
 	 (dir (expand-file-name dir)))
 (gnus-make-directory dir)
 (setq gnus-soup-areas nil)
 (gnus-message 4 "Packing %s..." packer)
 (if (zerop (call-process shell-file-name
 			     nil nil nil shell-command-switch
 			     (concat "cd " dir " ; " packer)))
 	(progn
 	  (call-process shell-file-name nil nil nil shell-command-switch
 			(concat "cd " dir " ; rm " files))
 	  (gnus-message 4 "Packing...done" packer))
 (error "Couldn't pack packet."))))
 (defun gnus-soup-parse-areas (file)
 "Parse soup area file FILE.
 The result is a of vectors, each containing one entry from the AREA file.
 The vector contain five strings,
 [prefix name encoding description number]
 though the two last may be nil if they are missing."
 (let (areas)
 (save-excursion
 (set-buffer (nnheader-find-file-noselect file 'force))
 (nnheader-temp-write (concat gnus-soup-directory "AREAS")
 (let ((areas gnus-soup-areas)
 	    area)
 	(while (setq area (pop areas))
 	  (insert
 	   (format
 	    "%s\t%s\t%s%s\n"
 	    (gnus-soup-area-prefix area)
 	    (gnus-soup-area-name area)
 	    (gnus-soup-area-encoding area)
 	    (if (or (gnus-soup-area-description area)
 		    (gnus-soup-area-number area))
 		(concat "\t" (or (gnus-soup-area-description
 				  area) "")
 			(if (gnus-soup-area-number area)
 			    (concat "\t" (int-to-string
 					  (gnus-soup-area-number area)))
 			  "")) ""))))))))
 (defun gnus-soup-write-replies (dir areas)
 "Write a REPLIES file in DIR containing AREAS."
 (when (equal (gnus-soup-area-name area) real-group)
 	(setq result area)))
 (unless result
 (setq result
 	    (vector (gnus-soup-unique-prefix)
 		    real-group
 		    (format "%c%c%c"
 			    gnus-soup-encoding-type
 			    gnus-soup-index-type
 			    (if (gnus-member-of-valid 'mail group) ?m ?n))
 		    nil nil)
 	      (format "cd %s ; %s" (expand-file-name dir)
 		      (format unpacker packet))))
 (gnus-message 4 "Unpacking...done")))
 (defun gnus-soup-send-packet (packet)
 (gnus-soup-unpack-packet
 gnus-soup-replies-directory gnus-soup-unpacker packet)
 (let ((replies (gnus-soup-parse-replies
 		  (concat gnus-soup-replies-directory "REPLIES"))))
 (save-excursion
 (while replies
 	(let* ((msg-file (concat gnus-soup-replies-directory
 				 (gnus-soup-reply-prefix (car replies))
 				 ".MSG"))
 	       (msg-buf (and (file-exists-p msg-file)
 			     (nnheader-find-file-noselect msg-file)))
 	       (tmp-buf (get-buffer-create " *soup send*"))
 	       beg end)
 	  (cond
 	   ((/= (gnus-soup-encoding-format
 		 (gnus-soup-reply-encoding (car replies)))
 		?n)
 	    (error "Unsupported encoding"))
 	   ((null msg-buf)
 	    t)
 	    (while (not (eobp))
 	      (unless (looking-at "#! *rnews +\\([0-9]+\\)")
 		(error "Bad header."))
 	      (forward-line 1)
 	      (setq beg (point)
 		    end (+ (point) (string-to-int
 				    (buffer-substring
 				     (match-beginning 1) (match-end 1)))))
 	      (switch-to-buffer tmp-buf)
 	      (erase-buffer)
 	      (insert-buffer-substring msg-buf beg end)
 	      (goto-char (point-min))
 	      (search-forward "\n\n")
 	      (forward-char -1)
 	      (insert mail-header-separator)
 	      (setq message-newsreader (setq message-mailer
 					     (gnus-extended-version)))
 	      (cond
 	       ((string= (gnus-soup-reply-kind (car replies)) "news")
 		(gnus-message 5 "Sending news message to %s..."
 			      (mail-fetch-field "newsgroups"))
 		(sit-for 1)
 		(let ((message-syntax-checks
 	    (kill-buffer msg-buf)
 	    (kill-buffer tmp-buf)
 	    (gnus-message 4 "Sent packet"))))
 	(setq replies (cdr replies)))
 t)))
 (provide 'gnus-soup)
 ;;; gnus-soup.el ends here

Mercurial > hg > xemacs-beta

comparison lisp/gnus/gnus-soup.el @ 108:360340f9fd5f r20-1b6