Mercurial > hg > xemacs-beta
diff lisp/gnus/nnmbox.el @ 70:131b0175ea99 r20-0b30
Import from CVS: tag r20-0b30
author | cvs |
---|---|
date | Mon, 13 Aug 2007 09:02:59 +0200 |
parents | 8b8b7f3559a2 |
children | 0d2f883870bc |
line wrap: on
line diff
--- a/lisp/gnus/nnmbox.el Mon Aug 13 09:00:04 2007 +0200 +++ b/lisp/gnus/nnmbox.el Mon Aug 13 09:02:59 2007 +0200 @@ -1,5 +1,5 @@ ;;; nnmbox.el --- mail mbox access for Gnus -;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. +;; Copyright (C) 1995,96 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> ;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> @@ -25,7 +25,7 @@ ;;; Commentary: ;; For an overview of what the interface functions do, please see the -;; Gnus sources. +;; Gnus sources. ;;; Code: @@ -82,21 +82,22 @@ (setq article (car sequence)) (setq art-string (nnmbox-article-string article)) (set-buffer nnmbox-mbox-buffer) - (when (or (search-forward art-string nil t) - (progn (goto-char (point-min)) - (search-forward art-string nil t))) - (setq start - (save-excursion - (re-search-backward - (concat "^" message-unix-mail-delimiter) nil t) - (point))) - (search-forward "\n\n" nil t) - (setq stop (1- (point))) - (set-buffer nntp-server-buffer) - (insert (format "221 %d Article retrieved.\n" article)) - (insert-buffer-substring nnmbox-mbox-buffer start stop) - (goto-char (point-max)) - (insert ".\n")) + (if (or (search-forward art-string nil t) + (progn (goto-char (point-min)) + (search-forward art-string nil t))) + (progn + (setq start + (save-excursion + (re-search-backward + (concat "^" message-unix-mail-delimiter) nil t) + (point))) + (search-forward "\n\n" nil t) + (setq stop (1- (point))) + (set-buffer nntp-server-buffer) + (insert (format "221 %d Article retrieved.\n" article)) + (insert-buffer-substring nnmbox-mbox-buffer start stop) + (goto-char (point-max)) + (insert ".\n"))) (setq sequence (cdr sequence)) (setq count (1+ count)) (and (numberp nnmail-large-newsgroup) @@ -115,8 +116,7 @@ (deffoo nnmbox-open-server (server &optional defs) (nnoo-change-server 'nnmbox server defs) - (nnmbox-create-mbox) - (cond + (cond ((not (file-exists-p nnmbox-mbox-file)) (nnmbox-close-server) (nnheader-report 'nnmbox "No such file: %s" nnmbox-mbox-file)) @@ -147,32 +147,32 @@ (save-excursion (set-buffer nnmbox-mbox-buffer) (goto-char (point-min)) - (when (search-forward (nnmbox-article-string article) nil t) - (let (start stop) - (re-search-backward (concat "^" message-unix-mail-delimiter) nil t) - (setq start (point)) - (forward-line 1) - (or (and (re-search-forward - (concat "^" message-unix-mail-delimiter) nil t) - (forward-line -1)) - (goto-char (point-max))) - (setq stop (point)) - (let ((nntp-server-buffer (or buffer nntp-server-buffer))) - (set-buffer nntp-server-buffer) - (erase-buffer) - (insert-buffer-substring nnmbox-mbox-buffer start stop) - (goto-char (point-min)) - (while (looking-at "From ") - (delete-char 5) - (insert "X-From-Line: ") - (forward-line 1)) - (if (numberp article) - (cons nnmbox-current-group article) - (nnmbox-article-group-number))))))) + (if (search-forward (nnmbox-article-string article) nil t) + (let (start stop) + (re-search-backward (concat "^" message-unix-mail-delimiter) nil t) + (setq start (point)) + (forward-line 1) + (or (and (re-search-forward + (concat "^" message-unix-mail-delimiter) nil t) + (forward-line -1)) + (goto-char (point-max))) + (setq stop (point)) + (let ((nntp-server-buffer (or buffer nntp-server-buffer))) + (set-buffer nntp-server-buffer) + (erase-buffer) + (insert-buffer-substring nnmbox-mbox-buffer start stop) + (goto-char (point-min)) + (while (looking-at "From ") + (delete-char 5) + (insert "X-From-Line: ") + (forward-line 1)) + (if (numberp article) + (cons nnmbox-current-group article) + (nnmbox-article-group-number))))))) (deffoo nnmbox-request-group (group &optional server dont-check) (let ((active (cadr (assoc group nnmbox-group-alist)))) - (cond + (cond ((or (null active) (null (nnmbox-possibly-change-newsgroup group server))) (nnheader-report 'nnmbox "No such group: %s" group)) @@ -181,21 +181,19 @@ (nnheader-insert "")) (t (nnheader-report 'nnmbox "Selected group %s" group) - (nnheader-insert "211 %d %d %d %s\n" + (nnheader-insert "211 %d %d %d %s\n" (1+ (- (cdr active) (car active))) (car active) (cdr active) group))))) (deffoo nnmbox-request-scan (&optional group server) - (nnmbox-possibly-change-newsgroup group server) (nnmbox-read-mbox) - (nnmail-get-new-mail - 'nnmbox + (nnmail-get-new-mail + 'nnmbox (lambda () (save-excursion (set-buffer nnmbox-mbox-buffer) (save-buffer))) - (file-name-directory nnmbox-mbox-file) - group + nnmbox-mbox-file group (lambda () (save-excursion (let ((in-buf (current-buffer))) @@ -210,8 +208,7 @@ (deffoo nnmbox-request-list (&optional server) (save-excursion (nnmail-find-file nnmbox-active-file) - (setq nnmbox-group-alist (nnmail-get-active)) - t)) + (setq nnmbox-group-alist (nnmail-get-active)))) (deffoo nnmbox-request-newgroups (date &optional server) (nnmbox-request-list server)) @@ -219,28 +216,28 @@ (deffoo nnmbox-request-list-newsgroups (&optional server) (nnheader-report 'nnmbox "LIST NEWSGROUPS is not implemented.")) -(deffoo nnmbox-request-expire-articles +(deffoo nnmbox-request-expire-articles (articles newsgroup &optional server force) (nnmbox-possibly-change-newsgroup newsgroup server) (let* ((is-old t) rest) (nnmail-activate 'nnmbox) - (save-excursion + (save-excursion (set-buffer nnmbox-mbox-buffer) (while (and articles is-old) (goto-char (point-min)) - (when (search-forward (nnmbox-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) - (nnmbox-delete-mail)) - (push (car articles) rest))) + (if (search-forward (nnmbox-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) + (nnmbox-delete-mail)) + (setq rest (cons (car articles) rest)))) (setq articles (cdr articles))) (save-buffer) ;; Find the lowest active article in this group. @@ -256,9 +253,10 @@ (deffoo nnmbox-request-move-article (article group server accept-form &optional last) + (nnmbox-possibly-change-newsgroup group server) (let ((buf (get-buffer-create " *nnmbox move*")) result) - (and + (and (nnmbox-request-article article group server) (save-excursion (set-buffer buf) @@ -266,8 +264,8 @@ (erase-buffer) (insert-buffer-substring nntp-server-buffer) (goto-char (point-min)) - (while (re-search-forward - "^X-Gnus-Newsgroup:" + (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)))) @@ -275,11 +273,10 @@ (kill-buffer buf) result) (save-excursion - (nnmbox-possibly-change-newsgroup group server) (set-buffer nnmbox-mbox-buffer) (goto-char (point-min)) - (when (search-forward (nnmbox-article-string article) nil t) - (nnmbox-delete-mail)) + (if (search-forward (nnmbox-article-string article) nil t) + (nnmbox-delete-mail)) (and last (save-buffer)))) result)) @@ -295,7 +292,7 @@ (if (looking-at "X-From-Line: ") (replace-match "From ") (insert "From nobody " (current-time-string) "\n")) - (and + (and (nnmail-activate 'nnmbox) (progn (set-buffer buf) @@ -304,24 +301,15 @@ (forward-line -1) (while (re-search-backward "^X-Gnus-Newsgroup: " nil t) (delete-region (point) (progn (forward-line 1) (point)))) - (when nnmail-cache-accepted-message-ids - (nnmail-cache-insert (nnmail-fetch-field "message-id"))) - (setq result (if (stringp group) - (list (cons group (nnmbox-active-number group))) - (nnmail-article-group 'nnmbox-active-number))) - (if (null result) - (setq result 'junk) - (setq result (car (nnmbox-save-mail result))))) + (setq result (nnmbox-save-mail (and (stringp group) group)))) (save-excursion (set-buffer nnmbox-mbox-buffer) (goto-char (point-max)) (insert-buffer-substring buf) - (when last - (when nnmail-cache-accepted-message-ids - (nnmail-cache-close)) - (nnmail-save-active nnmbox-group-alist nnmbox-active-file) - (save-buffer)))) - result)) + (and last (save-buffer)) + result) + (nnmail-save-active nnmbox-group-alist nnmbox-active-file)) + (car result))) (deffoo nnmbox-request-replace-article (article group buffer) (nnmbox-possibly-change-newsgroup group) @@ -349,10 +337,9 @@ (while (search-forward ident nil t) (setq found t) (nnmbox-delete-mail)) - (when found - (save-buffer))))) + (and found (save-buffer))))) ;; Remove the group from all structures. - (setq nnmbox-group-alist + (setq nnmbox-group-alist (delq (assoc group nnmbox-group-alist) nnmbox-group-alist) nnmbox-current-group nil) ;; Save the active file. @@ -370,11 +357,9 @@ (while (search-forward ident nil t) (replace-match new-ident t t) (setq found t)) - (when found - (save-buffer)))) + (and found (save-buffer)))) (let ((entry (assoc group nnmbox-group-alist))) - (when entry - (setcar entry new-name)) + (and entry (setcar entry new-name)) (setq nnmbox-current-group nil) ;; Save the new group alist. (nnmail-save-active nnmbox-group-alist nnmbox-active-file) @@ -384,7 +369,7 @@ ;;; Internal functions. ;; If FORCE, delete article no matter how many X-Gnus-Newsgroup -;; headers there are. If LEAVE-DELIM, don't delete the Unix mbox +;; headers there are. If LEAVE-DELIM, don't delete the Unix mbox ;; delimiter line. (defun nnmbox-delete-mail (&optional force leave-delim) ;; Delete the current X-Gnus-Newsgroup line. @@ -402,7 +387,7 @@ (match-beginning 0))) (progn (forward-line 1) - (or (and (re-search-forward (concat "^" message-unix-mail-delimiter) + (or (and (re-search-forward (concat "^" message-unix-mail-delimiter) nil t) (if (and (not (bobp)) leave-delim) (progn (forward-line -2) (point)) @@ -410,45 +395,48 @@ (point-max)))) (goto-char (point-min)) ;; 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)))))) + (if (or force (not (re-search-forward "^X-Gnus-Newsgroup: " nil t))) + (delete-region (point-min) (point-max)))))) (defun nnmbox-possibly-change-newsgroup (newsgroup &optional server) - (when (and server + (when (and server (not (nnmbox-server-opened server))) (nnmbox-open-server server)) - (when (or (not nnmbox-mbox-buffer) - (not (buffer-name nnmbox-mbox-buffer))) - (save-excursion - (set-buffer (setq nnmbox-mbox-buffer - (nnheader-find-file-noselect - nnmbox-mbox-file nil 'raw))) - (buffer-disable-undo (current-buffer)))) - (when (not nnmbox-group-alist) - (nnmail-activate 'nnmbox)) + (if (or (not nnmbox-mbox-buffer) + (not (buffer-name nnmbox-mbox-buffer))) + (save-excursion + (set-buffer (setq nnmbox-mbox-buffer + (nnheader-find-file-noselect + nnmbox-mbox-file nil 'raw))) + (buffer-disable-undo (current-buffer)))) + (if (not nnmbox-group-alist) + (nnmail-activate 'nnmbox)) (if newsgroup - (when (assoc newsgroup nnmbox-group-alist) - (setq nnmbox-current-group newsgroup)) + (if (assoc newsgroup nnmbox-group-alist) + (setq nnmbox-current-group newsgroup)) t)) (defun nnmbox-article-string (article) (if (numberp article) - (concat "\nX-Gnus-Newsgroup: " nnmbox-current-group ":" + (concat "\nX-Gnus-Newsgroup: " nnmbox-current-group ":" (int-to-string article) " ") (concat "\nMessage-ID: " article))) (defun nnmbox-article-group-number () (save-excursion (goto-char (point-min)) - (when (re-search-forward "^X-Gnus-Newsgroup: +\\([^:]+\\):\\([0-9]+\\) " - nil t) - (cons (buffer-substring (match-beginning 1) (match-end 1)) - (string-to-int - (buffer-substring (match-beginning 2) (match-end 2))))))) + (and (re-search-forward "^X-Gnus-Newsgroup: +\\([^:]+\\):\\([0-9]+\\) " + nil t) + (cons (buffer-substring (match-beginning 1) (match-end 1)) + (string-to-int + (buffer-substring (match-beginning 2) (match-end 2))))))) -(defun nnmbox-save-mail (group-art) +(defun nnmbox-save-mail (&optional group) "Called narrowed to an article." - (let ((delim (concat "^" message-unix-mail-delimiter))) + (let* ((nnmail-split-methods + (if group (list (list group "")) nnmail-split-methods)) + (group-art (nreverse (nnmail-article-group 'nnmbox-active-number))) + (delim (concat "^" message-unix-mail-delimiter))) (goto-char (point-min)) ;; This might come from somewhere else. (unless (looking-at delim) @@ -469,13 +457,14 @@ (defun nnmbox-insert-newsgroup-line (group-art) (save-excursion (goto-char (point-min)) - (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)))) + (if (search-forward "\n\n" nil t) + (progn + (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)) (defun nnmbox-active-number (group) @@ -486,17 +475,14 @@ ;; This group is new, so we create a new entry for it. ;; This might be a bit naughty... creating groups on the drop of ;; a hat, but I don't know... - (push (list group (setq active (cons 1 1))) - nnmbox-group-alist)) + (setq nnmbox-group-alist (cons (list group (setq active (cons 1 1))) + nnmbox-group-alist))) (cdr active))) -(defun nnmbox-create-mbox () - (when (not (file-exists-p nnmbox-mbox-file)) - (nnmail-write-region 1 1 nnmbox-mbox-file t 'nomesg))) - (defun nnmbox-read-mbox () (nnmail-activate 'nnmbox) - (nnmbox-create-mbox) + (if (not (file-exists-p nnmbox-mbox-file)) + (write-region 1 1 nnmbox-mbox-file t 'nomesg)) (if (and nnmbox-mbox-buffer (buffer-name nnmbox-mbox-buffer) (save-excursion @@ -507,7 +493,7 @@ (let ((delim (concat "^" message-unix-mail-delimiter)) (alist nnmbox-group-alist) start end number) - (set-buffer (setq nnmbox-mbox-buffer + (set-buffer (setq nnmbox-mbox-buffer (nnheader-find-file-noselect nnmbox-mbox-file nil 'raw))) (buffer-disable-undo (current-buffer)) @@ -520,30 +506,29 @@ (format "^X-Gnus-Newsgroup: %s:\\([0-9]+\\) " (caar alist)) nil t) (>= (setq number - (string-to-number + (string-to-number (buffer-substring (match-beginning 1) (match-end 1)))) (cdadar alist))) (setcdr (cadar alist) (1+ number))) (setq alist (cdr alist))) - + (goto-char (point-min)) (while (re-search-forward delim nil t) (setq start (match-beginning 0)) - (when (not (search-forward "\nX-Gnus-Newsgroup: " - (save-excursion - (setq end - (or - (and - (re-search-forward delim nil t) - (match-beginning 0)) - (point-max)))) - t)) - (save-excursion - (save-restriction - (narrow-to-region start end) - (nnmbox-save-mail - (nnmail-article-group 'nnmbox-active-number))))) + (if (not (search-forward "\nX-Gnus-Newsgroup: " + (save-excursion + (setq end + (or + (and + (re-search-forward delim nil t) + (match-beginning 0)) + (point-max)))) + t)) + (save-excursion + (save-restriction + (narrow-to-region start end) + (nnmbox-save-mail)))) (goto-char end)))))) (provide 'nnmbox)