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

comparison lisp/gnus/nnbabyl.el @ 30:ec9a17fef872 r19-15b98

Import from CVS: tag r19-15b98

author	cvs
date	Mon, 13 Aug 2007 08:52:29 +0200
parents	4103f0995bd7
children	c53a95d3c46d

comparison

equal deleted inserted replaced

-:7976500f47f9
+:ec9a17fef872
 ;; Boston, MA 02111-1307, USA.
 ;;; Commentary:
 ;; For an overview of what the interface functions do, please see the
 ;; Gnus sources.
 ;;; Code:
 (require 'nnheader)
 (require 'rmail)
 'headers)))
 (deffoo nnbabyl-open-server (server &optional defs)
 (nnoo-change-server 'nnbabyl server defs)
 (nnbabyl-create-mbox)
 (cond
 ((not (file-exists-p nnbabyl-mbox-file))
 (nnbabyl-close-server)
 (nnheader-report 'nnbabyl "No such file: %s" nnbabyl-mbox-file))
 ((file-directory-p nnbabyl-mbox-file)
 (nnbabyl-close-server)
 	  (goto-char (point-min))
 	  (end-of-line))
 	(while (and (not (looking-at ".+:"))
 		    (zerop (forward-line 1))))
 	(setq start (point))
 	(or (when (re-search-forward
 		   (concat "^" nnbabyl-mail-delimiter) nil t)
 	      (beginning-of-line)
 	      t)
 	    (goto-char (point-max)))
 	(setq stop (point))
 	  (set-buffer nntp-server-buffer)
 	  (erase-buffer)
 	  (insert-buffer-substring nnbabyl-mbox-buffer start stop)
 	  (goto-char (point-min))
 	  ;; If there is an EOOH header, then we have to remove some
 	  ;; duplicated headers.
 	  (setq summary-line (looking-at "Summary-line:"))
 	  (when (search-forward "\n*** EOOH ***" nil t)
 	    (if summary-line
 		;; The headers to be deleted are located before the
 		;; EOOH line...
 	    (nnbabyl-article-group-number)))))))
 (deffoo nnbabyl-request-group (group &optional server dont-check)
 (let ((active (cadr (assoc group nnbabyl-group-alist))))
 (save-excursion
 (cond
 ((or (null active)
 	    (null (nnbabyl-possibly-change-newsgroup group server)))
 	(nnheader-report 'nnbabyl "No such group: %s" group))
 (dont-check
 	(nnheader-report 'nnbabyl "Selected group %s" group)
 	(nnheader-insert ""))
 (t
 	(nnheader-report 'nnbabyl "Selected group %s" group)
 	(nnheader-insert "211 %d %d %d %s\n"
 			 (1+ (- (cdr active) (car active)))
 			 (car active) (cdr active) group))))))
 (deffoo nnbabyl-request-scan (&optional group server)
 (nnbabyl-possibly-change-newsgroup group server)
 (nnbabyl-read-mbox)
 (nnmail-get-new-mail
 'nnbabyl
 (lambda ()
 (save-excursion
 (set-buffer nnbabyl-mbox-buffer)
 (save-buffer)))
 (file-name-directory nnbabyl-mbox-file)
 (nnbabyl-possibly-change-newsgroup newsgroup server)
 (let* ((is-old t)
 	 rest)
 (nnmail-activate 'nnbabyl)
 (save-excursion
 (set-buffer nnbabyl-mbox-buffer)
 (gnus-set-text-properties (point-min) (point-max) nil)
 (while (and articles is-old)
 	(goto-char (point-min))
 	(when (search-forward (nnbabyl-article-string (car articles)) nil t)
 	  (if (setq is-old
 		    (nnmail-expired-article-p
 		     newsgroup
 		     (buffer-substring
 		      (point) (progn (end-of-line) (point))) force))
 	      (progn
 		(nnheader-message 5 "Deleting article %d in %s..."
 				  (car articles) newsgroup)
 		(nnbabyl-delete-mail))
 	    (push (car articles) rest)))
 	(setq articles (cdr articles)))
 (save-buffer)
 	  (setcar active (1+ (car active)))
 	  (goto-char (point-min))))
 (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)
 (nconc rest articles))))
 (deffoo nnbabyl-request-move-article
 (article group server accept-form &optional last)
 (let ((buf (get-buffer-create " *nnbabyl move*"))
 	result)
 (and
 (nnbabyl-request-article article group server)
 (save-excursion
 (set-buffer buf)
 (insert-buffer-substring nntp-server-buffer)
 (goto-char (point-min))
 (while (re-search-forward
 	       "^X-Gnus-Newsgroup:"
 	       (save-excursion (search-forward "\n\n" nil t) (point)) t)
 	 (delete-region (progn (beginning-of-line) (point))
 			(progn (forward-line 1) (point))))
 (setq result (eval accept-form))
 (kill-buffer (current-buffer))
 (deffoo nnbabyl-request-accept-article (group &optional server last)
 (nnbabyl-possibly-change-newsgroup group server)
 (nnmail-check-syntax)
 (let ((buf (current-buffer))
 	result beg)
 (and
 (nnmail-activate 'nnbabyl)
 (save-excursion
 (goto-char (point-min))
 (search-forward "\n\n" nil t)
 (forward-line -1)
 (save-excursion
 	 (while (re-search-backward "^X-Gnus-Newsgroup: " beg t)
 	   (delete-region (point) (progn (forward-line 1) (point)))))
+(nnmail-cache-insert (nnmail-fetch-field "message-id"))
 (setq result (car (nnbabyl-save-mail
 			  (if (stringp group)
 			      (list (cons group (nnbabyl-active-number group)))
 			    (nnmail-article-group 'nnbabyl-active-number)))))
 (set-buffer nnbabyl-mbox-buffer)
 (goto-char (point-max))
 (search-backward "\n\^_")
 (goto-char (match-end 0))
 (insert-buffer-substring buf)
 (when last
+	 (nnmail-cache-insert (nnmail-fetch-field "message-id"))
 	 (save-buffer)
 	 (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file))
 result))))
 (deffoo nnbabyl-request-replace-article (article group buffer)
 	  (setq found t)
 	  (nnbabyl-delete-mail))
 	(when found
 	  (save-buffer)))))
 ;; Remove the group from all structures.
 (setq nnbabyl-group-alist
 	(delq (assoc group nnbabyl-group-alist) nnbabyl-group-alist)
 	nnbabyl-current-group nil)
 ;; Save the active file.
 (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)
 t)
 ;; Only delete the article if no other groups owns it as well.
 (when (or force (not (re-search-forward "^X-Gnus-Newsgroup: " nil t)))
 	(delete-region (point-min) (point-max))))))
 (defun nnbabyl-possibly-change-newsgroup (newsgroup &optional server)
 (when (and server
 	     (not (nnbabyl-server-opened server)))
 (nnbabyl-open-server server))
 (when (or (not nnbabyl-mbox-buffer)
 	    (not (buffer-name nnbabyl-mbox-buffer)))
 (save-excursion (nnbabyl-read-mbox)))
 	(nnheader-report 'nnbabyl "No such group in file"))
 t))
 (defun nnbabyl-article-string (article)
 (if (numberp article)
 (concat "\nX-Gnus-Newsgroup: " nnbabyl-current-group ":"
 	      (int-to-string article) " ")
 (concat "\nMessage-ID: " article)))
 (defun nnbabyl-article-group-number ()
 (save-excursion
 	;; There may be an EOOH line here...
 	(when (looking-at "\\*\\*\\* EOOH \\*\\*\\*")
 	  (search-forward "\n\n" nil t))
 	(setq chars (- (point-max) (point))
 	      lines (max (- (count-lines (point) (point-max)) 1) 0))
 	;; Move back to the end of the headers.
 	(goto-char (point-min))
 	(search-forward "\n\n" nil t)
 	(forward-char -1)
 	(save-excursion
 	  (when (re-search-backward "^Lines: " nil t)
 	(goto-char (point-max))
 	(insert "\^_\n")))
 (when (search-forward "\n\n" nil t)
 (forward-char -1)
 (while group-art
 	(insert (format "X-Gnus-Newsgroup: %s:%d   %s\n"
 			(caar group-art) (cdar group-art)
 			(current-time-string)))
 	(setq group-art (cdr group-art))))
 t))
 ;; This buffer has changed since we read it last.  Possibly.
 (save-excursion
 (let ((delim (concat "^" nnbabyl-mail-delimiter))
 	    (alist nnbabyl-group-alist)
 	    start end number)
 	(set-buffer (setq nnbabyl-mbox-buffer
 			  (nnheader-find-file-noselect
 			   nnbabyl-mbox-file nil 'raw)))
 	;; Save previous buffer mode.
 	(setq nnbabyl-previous-buffer-mode
 	      (cons (cons (point-min) (point-max))
 		    major-mode))
 	(buffer-disable-undo (current-buffer))
 	(widen)
 	  (when (and (re-search-backward
 		      (format "^X-Gnus-Newsgroup: %s:\\([0-9]+\\) "
 			      (caar alist))
 		      nil t)
 		     (> (setq number
 			      (string-to-number
 			       (buffer-substring
 				(match-beginning 1) (match-end 1))))
 			(cdadar alist)))
 	    (setcdr (cadar alist) number))
 	  (setq alist (cdr alist)))
 	;; We go through the mbox and make sure that each and
 	;; every mail belongs to some group or other.
 	(goto-char (point-min))
 	(if (looking-at "\^L")
 	    (setq start (point))
 	  (re-search-forward delim nil t)
 	  (unless (search-backward "\nX-Gnus-Newsgroup: " start t)
 	    (goto-char end)
 	    (save-excursion
 	      (save-restriction
 		(narrow-to-region (goto-char start) end)
 		(nnbabyl-save-mail
 		 (nnmail-article-group 'nnbabyl-active-number))
 		(setq end (point-max)))))
 	  (goto-char (setq start end)))
 	(when (buffer-modified-p (current-buffer))
 	  (save-buffer))

Mercurial > hg > xemacs-beta

comparison lisp/gnus/nnbabyl.el @ 30:ec9a17fef872 r19-15b98