X-Git-Url: https://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fnnfolder.el;h=c3d0d1cdb91abb20c04a555eaf5cb8ae460fe806;hp=b50c6bde5b64beb1de59a023220b0c3e799602d0;hb=a2556858067503fc6719a777279ace07db95735e;hpb=b0cdd337e3c7babd0c42cb7d945266d9b653258b diff --git a/lisp/nnfolder.el b/lisp/nnfolder.el index b50c6bde5..c3d0d1cdb 100644 --- a/lisp/nnfolder.el +++ b/lisp/nnfolder.el @@ -1,6 +1,7 @@ ;;; nnfolder.el --- mail folder access for Gnus -;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002 -;; Free Software Foundation, Inc. + +;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, +;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. ;; Author: Simon Josefsson (adding MARKS) ;; ShengHuo Zhu (adding NOV) @@ -11,10 +12,10 @@ ;; 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 @@ -22,14 +23,16 @@ ;; 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: ;;; Code: +;; For Emacs < 22.2. +(eval-and-compile + (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) + (require 'nnheader) (require 'message) (require 'nnmail) @@ -39,9 +42,8 @@ (require 'gnus-util) (require 'gnus-range) -(eval-and-compile - (autoload 'gnus-article-unpropagatable-p "gnus-sum") - (autoload 'gnus-intersection "gnus-range")) +;; FIXME not explicitly used in this file. +(autoload 'gnus-article-unpropagatable-p "gnus-sum") (nnoo-declare nnfolder) @@ -155,8 +157,7 @@ the group. Then the marks file will be regenerated properly by Gnus.") (nnoo-define-basics nnfolder) (deffoo nnfolder-retrieve-headers (articles &optional group server fetch-old) - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (erase-buffer) (let (article start stop num) (nnfolder-possibly-change-group group server) @@ -200,9 +201,9 @@ the group. Then the marks file will be regenerated properly by Gnus.") ((search-backward (concat "\n" nnfolder-article-marker) nil t) (goto-char (match-end 0)) - (setq num (string-to-int + (setq num (string-to-number (buffer-substring - (point) (progn (end-of-line) (point))))) + (point) (point-at-eol)))) (goto-char start) (< num article))) ;; Check that we are before an article with a @@ -210,9 +211,9 @@ the group. Then the marks file will be regenerated properly by Gnus.") (search-forward (concat "\n" nnfolder-article-marker) nil t) (progn - (setq num (string-to-int + (setq num (string-to-number (buffer-substring - (point) (progn (end-of-line) (point))))) + (point) (point-at-eol)))) (> num article)) ;; Discard any article numbers before the one we're ;; now looking at. @@ -259,8 +260,7 @@ the group. Then the marks file will be regenerated properly by Gnus.") (deffoo nnfolder-request-article (article &optional group server buffer) (nnfolder-possibly-change-group group server) - (save-excursion - (set-buffer nnfolder-current-buffer) + (with-current-buffer nnfolder-current-buffer (goto-char (point-min)) (when (nnfolder-goto-article article) (let (start stop) @@ -285,33 +285,37 @@ the group. Then the marks file will be regenerated properly by Gnus.") (cons nnfolder-current-group (if (search-forward (concat "\n" nnfolder-article-marker) nil t) - (string-to-int - (buffer-substring - (point) (progn (end-of-line) (point)))) + (string-to-number (buffer-substring + (point) (point-at-eol))) -1)))))))) -(deffoo nnfolder-request-group (group &optional server dont-check) +(deffoo nnfolder-request-group (group &optional server dont-check info) (nnfolder-possibly-change-group group server t) (save-excursion - (if (not (assoc group nnfolder-group-alist)) - (nnheader-report 'nnfolder "No such group: %s" group) - (if dont-check - (progn - (nnheader-report 'nnfolder "Selected group %s" group) - t) - (let* ((active (assoc group nnfolder-group-alist)) - (group (car active)) - (range (cadr active))) - (cond - ((null active) - (nnheader-report 'nnfolder "No such group: %s" group)) - ((null nnfolder-current-group) - (nnheader-report 'nnfolder "Empty group: %s" group)) - (t - (nnheader-report 'nnfolder "Selected group %s" group) - (nnheader-insert "211 %d %d %d %s\n" - (1+ (- (cdr range) (car range))) - (car range) (cdr range) group)))))))) + (cond ((not (assoc group nnfolder-group-alist)) + (nnheader-report 'nnfolder "No such group: %s" group)) + ((file-directory-p (nnfolder-group-pathname group)) + (nnheader-report 'nnfolder "%s is a directory" + (file-name-as-directory + (let ((nnmail-pathname-coding-system nil)) + (nnfolder-group-pathname group))))) + (dont-check + (nnheader-report 'nnfolder "Selected group %s" group) + t) + (t + (let* ((active (assoc group nnfolder-group-alist)) + (group (car active)) + (range (cadr active))) + (cond + ((null active) + (nnheader-report 'nnfolder "No such group: %s" group)) + ((null nnfolder-current-group) + (nnheader-report 'nnfolder "Empty group: %s" group)) + (t + (nnheader-report 'nnfolder "Selected group %s" group) + (nnheader-insert "211 %d %d %d %s\n" + (1+ (- (cdr range) (car range))) + (car range) (cdr range) group)))))))) (deffoo nnfolder-request-scan (&optional group server) (nnfolder-possibly-change-group nil server) @@ -354,8 +358,7 @@ the group. Then the marks file will be regenerated properly by Gnus.") nnfolder-current-group (car inf)))) (when (and nnfolder-current-buffer (buffer-name nnfolder-current-buffer)) - (save-excursion - (set-buffer nnfolder-current-buffer) + (with-current-buffer nnfolder-current-buffer ;; If the buffer was modified, write the file out now. (nnfolder-save-buffer) ;; If we're shutting the server down, we need to kill the @@ -371,12 +374,21 @@ the group. Then the marks file will be regenerated properly by Gnus.") (deffoo nnfolder-request-create-group (group &optional server args) (nnfolder-possibly-change-group nil server) (nnmail-activate 'nnfolder) - (when group - (unless (assoc group nnfolder-group-alist) - (push (list group (cons 1 0)) nnfolder-group-alist) - (nnfolder-save-active nnfolder-group-alist nnfolder-active-file) - (nnfolder-read-folder group))) - t) + (cond ((zerop (length group)) + (nnheader-report 'nnfolder "Invalid (empty) group name")) + ((file-directory-p (nnfolder-group-pathname group)) + (nnheader-report 'nnfolder "%s is a directory" + (file-name-as-directory + (let ((nnmail-pathname-coding-system nil)) + (nnfolder-group-pathname group))))) + ((assoc group nnfolder-group-alist) + t) + (t + (push (list group (cons 1 0)) nnfolder-group-alist) + (nnfolder-save-active nnfolder-group-alist nnfolder-active-file) + (save-current-buffer + (nnfolder-read-folder group)) + t))) (deffoo nnfolder-request-list (&optional server) (nnfolder-possibly-change-group nil server) @@ -415,20 +427,24 @@ the group. Then the marks file will be regenerated properly by Gnus.") ;; The article numbers are increasing, so this result is sorted. (nreverse numbers))))) -(deffoo nnfolder-request-expire-articles - (articles newsgroup &optional server force) +(autoload 'gnus-request-group "gnus-int") +(declare-function gnus-request-create-group "gnus-int" + (group &optional gnus-command-method args)) + +(deffoo nnfolder-request-expire-articles (articles newsgroup + &optional server force) (nnfolder-possibly-change-group newsgroup server) - (let* ((is-old t) - ;; The articles we have deleted so far. - (deleted-articles nil) - ;; The articles that really exist and will - ;; be expired if they are old enough. - (maybe-expirable - (gnus-sorted-intersection articles (nnfolder-existing-articles)))) + (let ((is-old t) + ;; The articles we have deleted so far. + (deleted-articles nil) + ;; The articles that really exist and will + ;; be expired if they are old enough. + (maybe-expirable + (gnus-sorted-intersection articles (nnfolder-existing-articles))) + target) (nnmail-activate 'nnfolder) - (save-excursion - (set-buffer nnfolder-current-buffer) + (with-current-buffer nnfolder-current-buffer ;; Since messages are sorted in arrival order and expired in the ;; same order, we can stop as soon as we find a message that is ;; too old. @@ -444,21 +460,28 @@ the group. Then the marks file will be regenerated properly by Gnus.") (buffer-substring (point) (progn (end-of-line) (point))) force nnfolder-inhibit-expiry)) - (unless (eq nnmail-expiry-target 'delete) + (setq target nnmail-expiry-target) + (unless (eq target 'delete) (with-temp-buffer (nnfolder-request-article (car maybe-expirable) newsgroup server (current-buffer)) (let ((nnfolder-current-directory nil)) - (nnmail-expiry-target-group - nnmail-expiry-target newsgroup))) + (when (functionp target) + (setq target (funcall target newsgroup))) + (when (and target (not (eq target 'delete))) + (if (or (gnus-request-group target) + (gnus-request-create-group target)) + (nnmail-expiry-target-group target newsgroup) + (setq target nil))))) (nnfolder-possibly-change-group newsgroup server)) - (nnheader-message 5 "Deleting article %d in %s..." - (car maybe-expirable) newsgroup) - (nnfolder-delete-mail) - (unless (or gnus-nov-is-evil nnfolder-nov-is-evil) - (nnfolder-nov-delete-article newsgroup (car maybe-expirable))) - ;; Must remember which articles were actually deleted - (push (car maybe-expirable) deleted-articles))) + (when target + (nnheader-message 5 "Deleting article %d in %s..." + (car maybe-expirable) newsgroup) + (nnfolder-delete-mail) + (unless (or gnus-nov-is-evil nnfolder-nov-is-evil) + (nnfolder-nov-delete-article newsgroup (car maybe-expirable))) + ;; Must remember which articles were actually deleted + (push (car maybe-expirable) deleted-articles)))) (setq maybe-expirable (cdr maybe-expirable))) (unless nnfolder-inhibit-expiry (nnheader-message 5 "Deleting articles...done")) @@ -467,15 +490,14 @@ the group. Then the marks file will be regenerated properly by Gnus.") (nnfolder-save-active nnfolder-group-alist nnfolder-active-file) (gnus-sorted-difference articles (nreverse deleted-articles))))) -(deffoo nnfolder-request-move-article (article group server - accept-form &optional last) +(deffoo nnfolder-request-move-article (article group server accept-form + &optional last move-is-internal) (save-excursion (let ((buf (get-buffer-create " *nnfolder move*")) result) (and (nnfolder-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)) @@ -483,8 +505,7 @@ the group. Then the marks file will be regenerated properly by Gnus.") (concat "^" nnfolder-article-marker) (save-excursion (and (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) @@ -510,9 +531,9 @@ the group. Then the marks file will be regenerated properly by Gnus.") result art-group) (goto-char (point-min)) (when (looking-at "X-From-Line: ") - (save-match-data - (mail-header-unfold-field)) - (replace-match "From ")) + (replace-match "From ") + (while (progn (forward-line) (looking-at "[ \t]")) + (delete-char -1))) (with-temp-buffer (let ((nnmail-file-coding-system nnfolder-active-file-coding-system) (nntp-server-buffer (current-buffer))) @@ -526,7 +547,10 @@ the group. Then the marks file will be regenerated properly by Gnus.") (while (re-search-backward (concat "^" nnfolder-article-marker) nil t) (delete-region (point) (progn (forward-line 1) (point)))) (when nnmail-cache-accepted-message-ids - (nnmail-cache-insert (nnmail-fetch-field "message-id") group)) + (nnmail-cache-insert (nnmail-fetch-field "message-id") + group + (nnmail-fetch-field "subject") + (nnmail-fetch-field "from"))) (setq result (if (stringp group) (list (cons group (nnfolder-active-number group))) (setq art-group @@ -549,8 +573,7 @@ the group. Then the marks file will be regenerated properly by Gnus.") (deffoo nnfolder-request-replace-article (article group buffer) (nnfolder-possibly-change-group group) - (save-excursion - (set-buffer buffer) + (with-current-buffer buffer (goto-char (point-min)) (if (not (looking-at "X-From-Line: ")) (insert "From nobody " (current-time-string) "\n") @@ -567,8 +590,7 @@ the group. Then the marks file will be regenerated properly by Gnus.") (nnfolder-delete-mail) (insert-buffer-substring buffer) (unless (or gnus-nov-is-evil nnfolder-nov-is-evil) - (save-excursion - (set-buffer buffer) + (with-current-buffer buffer (let ((headers (nnfolder-parse-head article (point-min) (point-max)))) (with-current-buffer (nnfolder-open-nov group) @@ -601,8 +623,7 @@ the group. Then the marks file will be regenerated properly by Gnus.") (deffoo nnfolder-request-rename-group (group new-name &optional server) (nnfolder-possibly-change-group group server) - (save-excursion - (set-buffer nnfolder-current-buffer) + (with-current-buffer nnfolder-current-buffer (and (file-writable-p buffer-file-name) (ignore-errors (let ((new-file (nnfolder-group-pathname new-name))) @@ -642,8 +663,7 @@ the group. Then the marks file will be regenerated properly by Gnus.") (marker (concat "\n" nnfolder-article-marker)) (number "[0-9]+") (activemin (cdr active))) - (save-excursion - (set-buffer nnfolder-current-buffer) + (with-current-buffer nnfolder-current-buffer (goto-char (point-min)) (while (and (search-forward marker nil t) (re-search-forward number nil t)) @@ -823,7 +843,7 @@ deleted. Point is left where the deleted region was." (insert "\n")) (forward-char -1) (insert (format (concat nnfolder-article-marker "%d %s\n") - (cdr group-art) (current-time-string))))) + (cdr group-art) (message-make-date))))) (defun nnfolder-active-number (group) ;; Find the next article number in GROUP. @@ -871,8 +891,9 @@ deleted. Point is left where the deleted region was." (buffer (set-buffer (let ((nnheader-file-coding-system nnfolder-file-coding-system)) - (nnheader-find-file-noselect file))))) + (nnheader-find-file-noselect file t))))) (mm-enable-multibyte) ;; Use multibyte buffer for future copying. + (buffer-disable-undo) (if (equal (cadr (assoc group nnfolder-scantime-alist)) (nth 5 (file-attributes file))) ;; This looks up-to-date, so we don't do any scanning. @@ -895,11 +916,12 @@ deleted. Point is left where the deleted region was." (active (or (cadr (assoc group nnfolder-group-alist)) (cons 1 0))) (scantime (assoc group nnfolder-scantime-alist)) - (minid (lsh -1 -1)) + (minid (or (and (boundp 'most-positive-fixnum) + most-positive-fixnum) + (lsh -1 -1))) maxid start end newscantime novbuf articles newnum buffer-read-only) - (buffer-disable-undo) (setq maxid (cdr active)) (unless (or gnus-nov-is-evil nnfolder-nov-is-evil @@ -1026,9 +1048,7 @@ This command does not work if you use short group names." (when (not (message-mail-file-mbox-p file)) (ignore-errors (delete-file file))))) - (let ((files (directory-files nnfolder-directory)) - file) - (while (setq file (pop files)) + (dolist (file (directory-files nnfolder-directory)) (when (and (not (backup-file-name-p file)) (message-mail-file-mbox-p (nnheader-concat nnfolder-directory file))) @@ -1043,10 +1063,10 @@ This command does not work if you use short group names." (nnfolder-possibly-change-folder file) (nnfolder-possibly-change-group file) (nnfolder-close-group file)))) - (nnheader-message 5 ""))) + (nnheader-message 5 "")) (defun nnfolder-group-pathname (group) - "Make pathname for GROUP." + "Make file name for GROUP." (setq group (mm-encode-coding-string group nnmail-pathname-coding-system)) (let ((dir (file-name-as-directory (expand-file-name nnfolder-directory)))) @@ -1070,7 +1090,8 @@ This command does not work if you use short group names." (gnus-make-directory (file-name-directory (buffer-file-name))) (let ((coding-system-for-write (or nnfolder-file-coding-system-for-write - nnfolder-file-coding-system))) + nnfolder-file-coding-system)) + (copyright-update nil)) (save-buffer))) (unless (or gnus-nov-is-evil nnfolder-nov-is-evil) (nnfolder-save-nov))) @@ -1084,8 +1105,7 @@ This command does not work if you use short group names." (defun nnfolder-open-nov (group) (or (cdr (assoc group nnfolder-nov-buffer-alist)) (let ((buffer (get-buffer-create (format " *nnfolder overview %s*" group)))) - (save-excursion - (set-buffer buffer) + (with-current-buffer buffer (set (make-local-variable 'nnfolder-nov-buffer-file-name) (nnfolder-group-nov-pathname group)) (erase-buffer) @@ -1109,8 +1129,7 @@ This command does not work if you use short group names." (setq nnfolder-nov-buffer-alist (cdr nnfolder-nov-buffer-alist))))) (defun nnfolder-nov-delete-article (group article) - (save-excursion - (set-buffer (nnfolder-open-nov group)) + (with-current-buffer (nnfolder-open-nov group) (when (nnheader-find-nov-line article) (delete-region (point) (progn (forward-line 1) (point)))) t)) @@ -1120,8 +1139,7 @@ This command does not work if you use short group names." nil (let ((nov (nnfolder-group-nov-pathname nnfolder-current-group))) (when (file-exists-p nov) - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (erase-buffer) (nnheader-insert-file-contents nov) (if (and fetch-old @@ -1157,8 +1175,7 @@ This command does not work if you use short group names." (defun nnfolder-add-nov (group article headers) "Add a nov line for the GROUP base." - (save-excursion - (set-buffer (nnfolder-open-nov group)) + (with-current-buffer (nnfolder-open-nov group) (goto-char (point-max)) (mail-header-set-number headers article) (nnheader-insert-nov headers))) @@ -1173,7 +1190,7 @@ This command does not work if you use short group names." (let ((range (nth 0 action)) (what (nth 1 action)) (marks (nth 2 action))) - (assert (or (eq what 'add) (eq what 'del)) t + (assert (or (eq what 'add) (eq what 'del)) nil "Unknown request-set-mark action: %s" what) (dolist (mark marks) (setq nnfolder-marks (gnus-update-alist-soft @@ -1185,7 +1202,7 @@ This command does not work if you use short group names." (nnfolder-save-marks group server)) nil) -(deffoo nnfolder-request-update-info (group info &optional server) +(deffoo nnfolder-request-marks (group info &optional server) ;; Change servers. (when (and server (not (nnfolder-server-opened server))) @@ -1194,16 +1211,16 @@ This command does not work if you use short group names." (nnheader-message 8 "Updating marks for %s..." group) (nnfolder-open-marks group server) ;; Update info using `nnfolder-marks'. - (mapcar (lambda (pred) - (unless (memq (cdr pred) gnus-article-unpropagated-mark-lists) - (gnus-info-set-marks - info - (gnus-update-alist-soft - (cdr pred) - (cdr (assq (cdr pred) nnfolder-marks)) - (gnus-info-marks info)) - t))) - gnus-article-mark-lists) + (mapc (lambda (pred) + (unless (memq (cdr pred) gnus-article-unpropagated-mark-lists) + (gnus-info-set-marks + info + (gnus-update-alist-soft + (cdr pred) + (cdr (assq (cdr pred) nnfolder-marks)) + (gnus-info-marks info)) + t))) + gnus-article-mark-lists) (let ((seen (cdr (assq 'read nnfolder-marks)))) (gnus-info-set-read info (if (and (integerp (car seen)) @@ -1239,7 +1256,7 @@ This command does not work if you use short group names." nnfolder-marks-modtime)) (error (or (gnus-yes-or-no-p (format "Could not write to %s (%s). Continue? " file err)) - (error "Cannot write to %s (%s)" err)))))) + (error "Cannot write to %s (%s)" file err)))))) (defun nnfolder-open-marks (group server) (let ((file (nnfolder-group-marks-pathname group)))