X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fnnmbox.el;h=4eb98cf81e2ac569107c6d976213b01653a060db;hp=bf62dfb62dbe8d04bda39c0c9d46189150ca4bb9;hb=dd9fdb9123576f1c0fa65094365f2ba83937b044;hpb=29586a7196dda1f33c4a4683979323d6321c1ee9 diff --git a/lisp/nnmbox.el b/lisp/nnmbox.el index bf62dfb62..4eb98cf81 100644 --- a/lisp/nnmbox.el +++ b/lisp/nnmbox.el @@ -1,23 +1,25 @@ ;;; nnmbox.el --- mail mbox access for Gnus -;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000 -;; Free Software Foundation, Inc. +;; Copyright (C) 1995-2014 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen -;; Masanobu UMEDA +;; Masanobu UMEDA ;; Keywords: news, mail ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; along with GNU Emacs. If not, see . ;;; Commentary: @@ -36,24 +38,16 @@ (nnoo-declare nnmbox) (defvoo nnmbox-mbox-file (expand-file-name "~/mbox") - "The name of the mail box file in the user's home directory. - -This variable is a virtual server slot. See the Gnus manual for details.") + "The name of the mail box file in the user's home directory.") (defvoo nnmbox-active-file (expand-file-name "~/.mbox-active") - "The name of the active file for the mail box. - -This variable is a virtual server slot. See the Gnus manual for details.") + "The name of the active file for the mail box.") (defvoo nnmbox-get-new-mail t - "If non-nil, nnmbox will check the incoming mail file and split the mail. - -This variable is a virtual server slot. See the Gnus manual for details.") + "If non-nil, nnmbox will check the incoming mail file and split the mail.") (defvoo nnmbox-prepare-save-mail-hook nil - "Hook run narrowed to an article before saving. - -This variable is a virtual server slot. See the Gnus manual for details.") + "Hook run narrowed to an article before saving.") @@ -63,7 +57,7 @@ This variable is a virtual server slot. See the Gnus manual for details.") (defvoo nnmbox-current-group nil "Current nnmbox news group directory.") -(defconst nnmbox-mbox-buffer nil) +(defvar nnmbox-mbox-buffer nil) (defvoo nnmbox-status-string "") @@ -84,8 +78,7 @@ This variable is a virtual server slot. See the Gnus manual for details.") (nnoo-define-basics nnmbox) (deffoo nnmbox-retrieve-headers (sequence &optional newsgroup server fetch-old) - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (erase-buffer) (let ((number (length sequence)) (count 0) @@ -154,32 +147,32 @@ This variable is a virtual server slot. See the Gnus manual for details.") (deffoo nnmbox-request-article (article &optional newsgroup server buffer) (nnmbox-possibly-change-newsgroup newsgroup server) - (save-excursion - (set-buffer nnmbox-mbox-buffer) - (when (nnmbox-find-article article) - (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 nil))))))) - -(deffoo nnmbox-request-group (group &optional server dont-check) + (with-current-buffer nnmbox-mbox-buffer + (save-excursion + (when (nnmbox-find-article article) + (let (start stop) + (re-search-backward (concat "^" message-unix-mail-delimiter) nil t) + (setq start (point)) + (forward-line 1) + (setq stop (if (re-search-forward (concat "^" + message-unix-mail-delimiter) + nil 'move) + (match-beginning 0) + (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 nil)))))))) + +(deffoo nnmbox-request-group (group &optional server dont-check info) (nnmbox-possibly-change-newsgroup nil server) (let ((active (cadr (assoc group nnmbox-group-alist)))) (cond @@ -213,8 +206,7 @@ This variable is a virtual server slot. See the Gnus manual for details.") (nnmail-get-new-mail 'nnmbox (lambda () - (save-excursion - (set-buffer nnmbox-mbox-buffer) + (with-current-buffer nnmbox-mbox-buffer (nnmbox-save-buffer))) (file-name-directory nnmbox-mbox-file) group @@ -258,21 +250,20 @@ This variable is a virtual server slot. See the Gnus manual for details.") rest) (nnmail-activate 'nnmbox) - (save-excursion - (set-buffer nnmbox-mbox-buffer) + (with-current-buffer nnmbox-mbox-buffer (while (and articles is-old) (when (nnmbox-find-article (car articles)) (if (setq is-old (nnmail-expired-article-p newsgroup - (buffer-substring - (point) (progn (end-of-line) (point))) force)) + (buffer-substring (point) (line-end-position)) + force)) (progn (unless (eq nnmail-expiry-target 'delete) (with-temp-buffer (nnmbox-request-article (car articles) - newsgroup server - (current-buffer)) + newsgroup server + (current-buffer)) (let ((nnml-current-directory nil)) (nnmail-expiry-target-group nnmail-expiry-target newsgroup))) @@ -292,21 +283,19 @@ This variable is a virtual server slot. See the Gnus manual for details.") (nconc rest articles)))) (deffoo nnmbox-request-move-article - (article group server accept-form &optional last) + (article group server accept-form &optional last move-is-internal) (let ((buf (get-buffer-create " *nnmbox move*")) result) (and (nnmbox-request-article article group server) - (save-excursion - (set-buffer buf) + (with-current-buffer buf (erase-buffer) (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)))) + (gnus-delete-line)) (setq result (eval accept-form)) (kill-buffer buf) result) @@ -322,36 +311,45 @@ This variable is a virtual server slot. See the Gnus manual for details.") (nnmbox-possibly-change-newsgroup group server) (nnmail-check-syntax) (let ((buf (current-buffer)) - result) - (goto-char (point-min)) - ;; The From line may have been quoted by movemail. - (when (looking-at (concat ">" message-unix-mail-delimiter)) - (delete-char 1)) - (if (looking-at "X-From-Line: ") - (replace-match "From ") - (insert "From nobody " (current-time-string) "\n")) + result cont) (and (nnmail-activate 'nnmbox) - (progn - (set-buffer buf) + (with-temp-buffer + (insert-buffer-substring buf) (goto-char (point-min)) - (search-forward "\n\n" nil t) - (forward-line -1) + (cond (;; The From line may have been quoted by movemail. + (looking-at (concat ">" message-unix-mail-delimiter)) + (delete-char 1) + (forward-line 1)) + ((looking-at "X-From-Line: ") + (replace-match "From ") + (forward-line 1)) + (t + (insert "From nobody " (current-time-string) "\n"))) + (narrow-to-region (point) + (if (search-forward "\n\n" nil 'move) + (1- (point)) + (point))) (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"))) + (nnmail-cache-insert (message-fetch-field "message-id") + group + (message-fetch-field "subject") + (message-fetch-field "from"))) + (widen) (setq result (if (stringp group) (list (cons group (nnmbox-active-number group))) (nnmail-article-group 'nnmbox-active-number))) - (if (and (null result) - (yes-or-no-p "Moved to `junk' group; delete article? ")) - (setq result 'junk) - (setq result (car (nnmbox-save-mail result))))) - (save-excursion - (set-buffer nnmbox-mbox-buffer) + (prog1 + (if (and (null result) + (yes-or-no-p "Moved to `junk' group; delete article? ")) + (setq result 'junk) + (setq result (car (nnmbox-save-mail result)))) + (setq cont (buffer-string)))) + (with-current-buffer nnmbox-mbox-buffer (goto-char (point-max)) - (insert-buffer-substring buf) + (insert cont) (when last (when nnmail-cache-accepted-message-ids (nnmail-cache-close)) @@ -361,12 +359,24 @@ This variable is a virtual server slot. See the Gnus manual for details.") (deffoo nnmbox-request-replace-article (article group buffer) (nnmbox-possibly-change-newsgroup group) - (save-excursion - (set-buffer nnmbox-mbox-buffer) + (with-current-buffer nnmbox-mbox-buffer (if (not (nnmbox-find-article article)) nil (nnmbox-delete-mail t t) - (insert-buffer-substring buffer) + (insert + (with-temp-buffer + (insert-buffer-substring buffer) + (goto-char (point-min)) + (when (looking-at "X-From-Line:") + (delete-region (point) (progn (forward-line 1) (point)))) + (while (re-search-forward (concat "^" message-unix-mail-delimiter) + nil t) + (goto-char (match-beginning 0)) + (insert ">")) + (goto-char (point-max)) + (unless (bolp) + (insert "\n")) + (buffer-string))) (nnmbox-save-buffer) t))) @@ -375,8 +385,7 @@ This variable is a virtual server slot. See the Gnus manual for details.") ;; Delete all articles in GROUP. (if (not force) () ; Don't delete the articles. - (save-excursion - (set-buffer nnmbox-mbox-buffer) + (with-current-buffer nnmbox-mbox-buffer (goto-char (point-min)) ;; Delete all articles in this group. (let ((ident (concat "\nX-Gnus-Newsgroup: " nnmbox-current-group ":")) @@ -396,8 +405,7 @@ This variable is a virtual server slot. See the Gnus manual for details.") (deffoo nnmbox-request-rename-group (group new-name &optional server) (nnmbox-possibly-change-newsgroup group server) - (save-excursion - (set-buffer nnmbox-mbox-buffer) + (with-current-buffer nnmbox-mbox-buffer (goto-char (point-min)) (let ((ident (concat "\nX-Gnus-Newsgroup: " nnmbox-current-group ":")) (new-ident (concat "\nX-Gnus-Newsgroup: " new-name ":")) @@ -431,28 +439,25 @@ This variable is a virtual server slot. See the Gnus manual for details.") (if (not force) (nnmbox-record-deleted-article (nnmbox-article-group-number t))) (or force - (delete-region - (progn (beginning-of-line) (point)) - (progn (forward-line 1) (point)))) + (gnus-delete-line)) ;; Beginning of the article. (save-excursion (save-restriction (narrow-to-region - (save-excursion - (re-search-backward (concat "^" message-unix-mail-delimiter) nil t) - (if leave-delim (progn (forward-line 1) (point)) - (match-beginning 0))) - (progn - (forward-line 1) - (or (and (re-search-forward (concat "^" message-unix-mail-delimiter) - nil t) - (if (and (not (bobp)) leave-delim) - (progn (forward-line -2) (point)) - (match-beginning 0))) - (point-max)))) + (prog2 + (re-search-backward (concat "^" message-unix-mail-delimiter) nil t) + (if leave-delim (progn (forward-line 1) (point)) + (match-beginning 0)) + (forward-line 1)) + (or (and (re-search-forward (concat "^" message-unix-mail-delimiter) + nil t) + (match-beginning 0)) + (point-max))) (goto-char (point-min)) ;; Only delete the article if no other group owns it as well. - (when (or force (not (re-search-forward "^X-Gnus-Newsgroup: " nil t))) + (when (or force + (not (re-search-forward "^X-Gnus-Newsgroup: " nil t)) + (search-backward "\n\n" nil t)) (delete-region (point-min) (point-max)))))) (defun nnmbox-possibly-change-newsgroup (newsgroup &optional server) @@ -483,7 +488,7 @@ This variable is a virtual server slot. See the Gnus manual for details.") (when (re-search-forward "^X-Gnus-Newsgroup: +\\([^:]+\\):\\([0-9]+\\) " nil t) (cons (buffer-substring (match-beginning 1) (match-end 1)) - (string-to-int + (string-to-number (buffer-substring (match-beginning 2) (match-end 2))))))) (defun nnmbox-in-header-p (pos) @@ -560,24 +565,26 @@ This variable is a virtual server slot. See the Gnus manual for details.") (let ((delim (concat "^" message-unix-mail-delimiter))) (goto-char (point-min)) ;; This might come from somewhere else. - (unless (looking-at delim) - (insert "From nobody " (current-time-string) "\n") - (goto-char (point-min))) + (if (looking-at delim) + (forward-line 1) + (insert "From nobody " (current-time-string) "\n")) ;; Quote all "From " lines in the article. - (forward-line 1) (while (re-search-forward delim nil t) - (beginning-of-line) - (insert "> ")) - (nnmail-insert-lines) - (nnmail-insert-xref group-art) - (nnmbox-insert-newsgroup-line group-art) - (let ((alist group-art)) - (while alist - (nnmbox-record-active-article (car alist)) - (setq alist (cdr alist)))) - (run-hooks 'nnmail-prepare-save-mail-hook) - (run-hooks 'nnmbox-prepare-save-mail-hook) - group-art)) + (goto-char (match-beginning 0)) + (insert ">"))) + (goto-char (point-max)) + (unless (bolp) + (insert "\n")) + (nnmail-insert-lines) + (nnmail-insert-xref group-art) + (nnmbox-insert-newsgroup-line group-art) + (let ((alist group-art)) + (while alist + (nnmbox-record-active-article (car alist)) + (setq alist (cdr alist)))) + (run-hooks 'nnmail-prepare-save-mail-hook) + (run-hooks 'nnmbox-prepare-save-mail-hook) + group-art) (defun nnmbox-insert-newsgroup-line (group-art) (save-excursion @@ -610,15 +617,15 @@ This variable is a virtual server slot. See the Gnus manual for details.") nnmbox-file-coding-system)) (dir (file-name-directory nnmbox-mbox-file))) (and dir (gnus-make-directory dir)) - (nnmail-write-region 1 1 nnmbox-mbox-file t 'nomesg)))) + (nnmail-write-region (point-min) (point-min) + nnmbox-mbox-file t 'nomesg)))) (defun nnmbox-read-mbox () (nnmail-activate 'nnmbox) (nnmbox-create-mbox) (if (and nnmbox-mbox-buffer (buffer-name nnmbox-mbox-buffer) - (save-excursion - (set-buffer nnmbox-mbox-buffer) + (with-current-buffer nnmbox-mbox-buffer (= (buffer-size) (nnheader-file-size nnmbox-mbox-file)))) () (save-excursion @@ -633,6 +640,7 @@ This variable is a virtual server slot. See the Gnus manual for details.") nnmbox-mbox-file t t)))) (mm-enable-multibyte) (buffer-disable-undo) + (gnus-add-buffer) ;; Go through the group alist and compare against the mbox file. (while alist @@ -688,7 +696,7 @@ This variable is a virtual server slot. See the Gnus manual for details.") (let (alist) (while (re-search-forward " \\([^:]+\\):\\([0-9]+\\)" end-header t) (push (cons (match-string 1) - (string-to-int (match-string 2))) alist)) + (string-to-number (match-string 2))) alist)) (nnmbox-insert-newsgroup-line alist)) ;; this is really a new article (nnmbox-save-mail