;;; nnml.el --- mail spool access for Gnus
-;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001
-;; Free Software Foundation, Inc.
-;; Author: Simon Josefsson <simon@josefsson.org> (adding MARKS)
-;; Lars Magne Ingebrigtsen <larsi@gnus.org>
-;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
+;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
+;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+
+;; Authors: Didier Verna <didier@xemacs.org> (adding compaction)
+;; Simon Josefsson <simon@josefsson.org> (adding MARKS)
+;; Lars Magne Ingebrigtsen <larsi@gnus.org>
+;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
;; 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
;; 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 <http://www.gnu.org/licenses/>.
;;; Commentary:
(require 'nnoo)
(eval-when-compile (require 'cl))
+;; FIXME first is unused in this file.
+(autoload 'gnus-article-unpropagatable-p "gnus-sum")
+(autoload 'gnus-backlog-remove-article "gnus-bcklg")
+
(nnoo-declare nnml)
(defvoo nnml-directory message-directory
- "Spool directory for the nnml mail backend.
-
-This variable is a virtual server slot. See the Gnus manual for details.")
+ "Spool directory for the nnml mail backend.")
(defvoo nnml-active-file
(expand-file-name "active" nnml-directory)
- "Mail active file.
-
-This variable is a virtual server slot. See the Gnus manual for details.")
+ "Mail active file.")
(defvoo nnml-newsgroups-file
(expand-file-name "newsgroups" nnml-directory)
- "Mail newsgroups description file.
-
-This variable is a virtual server slot. See the Gnus manual for details.")
+ "Mail newsgroups description file.")
(defvoo nnml-get-new-mail t
- "If non-nil, nnml 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, nnml will check the incoming mail file and split the mail.")
(defvoo nnml-nov-is-evil nil
"If non-nil, Gnus will never generate and use nov databases for mail spools.
set this to t, and want to set it to nil again, you should always run
the `nnml-generate-nov-databases' command. The function will go
through all nnml directories and generate nov databases for them
-all. This may very well take some time.
-
-This variable is a virtual server slot. See the Gnus manual for details.")
+all. This may very well take some time.")
(defvoo nnml-marks-is-evil nil
"If non-nil, Gnus will never generate and use marks file for mail spools.
to t, and want to set it to nil again, you should always remove the
corresponding marks file (usually named `.marks' in the nnml group
directory, but see `nnml-marks-file-name') for the group. Then the
-marks file will be regenerated properly by Gnus.
-
-This variable is a virtual server slot. See the Gnus manual for details.")
+marks file will be regenerated properly by Gnus.")
(defvoo nnml-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.")
(defvoo nnml-inhibit-expiry nil
- "If non-nil, inhibit expiry.
+ "If non-nil, inhibit expiry.")
+
+(defvoo nnml-use-compressed-files nil
+ "If non-nil, allow using compressed message files.
-This variable is a virtual server slot. See the Gnus manual for details.")
+If it is a string, use it as the file extension which specifies
+the compression program. You can set it to \".bz2\" if your Emacs
+supports auto-compression using the bzip2 program. A value of t
+is equivalent to \".gz\".")
+(defvoo nnml-compressed-files-size-threshold 1000
+ "Default size threshold for compressed message files.
+Message files with bodies larger than that many characters will
+be automatically compressed if `nnml-use-compressed-files' is
+non-nil.")
\f
(defvoo nnml-generate-active-function 'nnml-generate-active-info)
(defvar nnml-nov-buffer-file-name nil)
-(defvar nnml-check-directory-twice t
- "If t, to make sure nothing went wrong when reading over NFS --
-check twice.")
(defvoo nnml-file-coding-system nnmail-file-coding-system)
(defvoo nnml-marks nil)
-\f
+(defvar nnml-marks-modtime (gnus-make-hashtable))
+\f
;;; Interface functions.
(nnoo-define-basics nnml)
+(eval-when-compile
+ (defsubst nnml-group-name-charset (group server-or-method)
+ (gnus-group-name-charset
+ (if (stringp server-or-method)
+ (gnus-server-to-method
+ (if (string-match "\\+" server-or-method)
+ (concat (substring server-or-method 0 (match-beginning 0))
+ ":" (substring server-or-method (match-end 0)))
+ (concat "nnml:" server-or-method)))
+ (or server-or-method gnus-command-method '(nnml "")))
+ group)))
+
+(defun nnml-decoded-group-name (group &optional server-or-method)
+ "Return a decoded group name of GROUP on SERVER-OR-METHOD."
+ (if nnmail-group-names-not-encoded-p
+ group
+ (mm-decode-coding-string
+ group
+ (nnml-group-name-charset group server-or-method))))
+
+(defun nnml-encoded-group-name (group &optional server-or-method)
+ "Return an encoded group name of GROUP on SERVER-OR-METHOD."
+ (mm-encode-coding-string
+ group
+ (nnml-group-name-charset group server-or-method)))
+
+(defun nnml-group-pathname (group &optional file server)
+ "Return an absolute file name of FILE for GROUP on SERVER."
+ (nnmail-group-pathname (inline (nnml-decoded-group-name group server))
+ nnml-directory file))
+
(deffoo nnml-retrieve-headers (sequence &optional group server fetch-old)
(when (nnml-possibly-change-directory group server)
- (save-excursion
- (set-buffer nntp-server-buffer)
+ (with-current-buffer nntp-server-buffer
(erase-buffer)
(let* ((file nil)
(number (length sequence))
(count 0)
(file-name-coding-system nnmail-pathname-coding-system)
- beg article
- (nnml-check-directory-twice
- (and nnml-check-directory-twice
- ;; To speed up, disable it in some case.
- (or (not (numberp nnmail-large-newsgroup))
- (<= number nnmail-large-newsgroup)))))
+ beg article)
(if (stringp (car sequence))
'headers
(if (nnml-retrieve-headers-with-nov sequence fetch-old)
(setq beg (point))
(nnheader-insert-head file)
(goto-char beg)
- (if (search-forward "\n\n" nil t)
+ (if (re-search-forward "\n\r?\n" nil t)
(forward-char -1)
(goto-char (point-max))
(insert "\n\n"))
(file-name-coding-system nnmail-pathname-coding-system)
path gpath group-num)
(if (stringp id)
- (when (and (setq group-num (nnml-find-group-number id))
+ (when (and (setq group-num (nnml-find-group-number id server))
(cdr
(assq (cdr group-num)
- (nnml-article-to-file-alist
- (setq gpath
- (nnmail-group-pathname
- (car group-num)
- nnml-directory))))))
+ (nnheader-article-to-file-alist
+ (setq gpath (nnml-group-pathname (car group-num)
+ nil server))))))
(setq path (concat gpath (int-to-string (cdr group-num)))))
(setq path (nnml-article-to-file id)))
(cond
(nnheader-report 'nnml "Article %s retrieved" id)
;; We return the article number.
(cons (if group-num (car group-num) group)
- (string-to-int (file-name-nondirectory path)))))))
+ (string-to-number (file-name-nondirectory path)))))))
-(deffoo nnml-request-group (group &optional server dont-check)
- (let ((file-name-coding-system nnmail-pathname-coding-system))
+(deffoo nnml-request-group (group &optional server dont-check info)
+ (let ((file-name-coding-system nnmail-pathname-coding-system)
+ (decoded (nnml-decoded-group-name group server)))
(cond
((not (nnml-possibly-change-directory group server))
(nnheader-report 'nnml "Invalid group (no such directory)"))
((not (file-directory-p nnml-current-directory))
(nnheader-report 'nnml "%s is not a directory" nnml-current-directory))
(dont-check
- (nnheader-report 'nnml "Group %s selected" group)
+ (nnheader-report 'nnml "Group %s selected" decoded)
t)
(t
(nnheader-re-read-dir nnml-current-directory)
(nnmail-activate 'nnml)
(let ((active (nth 1 (assoc group nnml-group-alist))))
(if (not active)
- (nnheader-report 'nnml "No such group: %s" group)
- (nnheader-report 'nnml "Selected group %s" group)
+ (nnheader-report 'nnml "No such group: %s" decoded)
+ (nnheader-report 'nnml "Selected group %s" decoded)
(nnheader-insert "211 %d %d %d %s\n"
(max (1+ (- (cdr active) (car active))) 0)
(car active) (cdr active) group)))))))
(deffoo nnml-request-scan (&optional group server)
(setq nnml-article-file-alist nil)
(nnml-possibly-change-directory group server)
- (nnmail-get-new-mail 'nnml 'nnml-save-nov nnml-directory group))
+ (nnmail-get-new-mail 'nnml 'nnml-save-incremental-nov nnml-directory group))
(deffoo nnml-close-group (group &optional server)
(setq nnml-article-file-alist nil)
(nnml-possibly-change-directory nil server)
(nnmail-activate 'nnml)
(cond
+ ((let ((file (directory-file-name (nnml-group-pathname group nil server)))
+ (file-name-coding-system nnmail-pathname-coding-system))
+ (and (file-exists-p file)
+ (not (file-directory-p file))))
+ (nnheader-report 'nnml "%s is a file"
+ (directory-file-name (nnml-group-pathname group
+ nil server))))
((assoc group nnml-group-alist)
t)
- ((and (file-exists-p (nnmail-group-pathname group nnml-directory))
- (not (file-directory-p (nnmail-group-pathname group nnml-directory))))
- (nnheader-report 'nnml "%s is a file"
- (nnmail-group-pathname group nnml-directory)))
(t
(let (active)
(push (list group (setq active (cons 1 0)))
nnml-group-alist)
- (nnml-possibly-create-directory group)
+ (nnml-possibly-create-directory group server)
(nnml-possibly-change-directory group server)
- (let ((articles (nnml-directory-articles nnml-current-directory)))
+ (let* ((file-name-coding-system nnmail-pathname-coding-system)
+ (articles (nnml-directory-articles nnml-current-directory)))
(when articles
(setcar active (apply 'min articles))
(setcdr active (apply 'max articles))))
(deffoo nnml-request-expire-articles (articles group &optional server force)
(nnml-possibly-change-directory group server)
- (let ((active-articles
- (nnml-directory-articles nnml-current-directory))
- (is-old t)
- article rest mod-time number)
+ (let* ((file-name-coding-system nnmail-pathname-coding-system)
+ (active-articles
+ (nnml-directory-articles nnml-current-directory))
+ (is-old t)
+ (decoded (nnml-decoded-group-name group server))
+ article rest mod-time number target)
(nnmail-activate 'nnml)
(setq active-articles (sort active-articles '<))
(setq articles (gnus-sorted-intersection articles active-articles))
(while (and articles is-old)
- (when (setq article (nnml-article-to-file (setq number (pop articles))))
- (when (setq mod-time (nth 5 (file-attributes article)))
- (if (and (nnml-deletable-article-p group number)
- (setq is-old
- (nnmail-expired-article-p group mod-time force
- nnml-inhibit-expiry)))
- (progn
- ;; Allow a special target group.
- (unless (eq nnmail-expiry-target 'delete)
- (with-temp-buffer
- (nnml-request-article number group server
- (current-buffer))
- (let ((nnml-current-directory nil))
- (nnmail-expiry-target-group
- nnmail-expiry-target group))))
- (nnheader-message 5 "Deleting article %s in %s"
- number group)
- (condition-case ()
- (funcall nnmail-delete-file-function article)
- (file-error
- (push number rest)))
- (setq active-articles (delq number active-articles))
- (nnml-nov-delete-article group number))
- (push number rest)))))
+ (if (and (setq article (nnml-article-to-file
+ (setq number (pop articles))))
+ (setq mod-time (nth 5 (file-attributes article)))
+ (nnml-deletable-article-p group number)
+ (setq is-old (nnmail-expired-article-p group mod-time force
+ nnml-inhibit-expiry)))
+ (progn
+ ;; Allow a special target group.
+ (setq target nnmail-expiry-target)
+ (unless (eq target 'delete)
+ (with-temp-buffer
+ (nnml-request-article number group server (current-buffer))
+ (let (nnml-current-directory
+ nnml-current-group
+ nnml-article-file-alist)
+ (when (functionp target)
+ (setq target (funcall target group)))
+ (when (and target (not (eq target 'delete)))
+ (if (or (gnus-request-group target)
+ (gnus-request-create-group target))
+ (nnmail-expiry-target-group target group)
+ (setq target nil)))))
+ ;; Maybe directory is changed during nnmail-expiry-target-group.
+ (nnml-possibly-change-directory group server))
+ (if target
+ (progn
+ (nnheader-message 5 "Deleting article %s in %s"
+ number decoded)
+ (condition-case ()
+ (funcall nnmail-delete-file-function article)
+ (file-error
+ (push number rest)))
+ (setq active-articles (delq number active-articles))
+ (nnml-nov-delete-article group number))
+ (push number rest)))
+ (push number rest)))
(let ((active (nth 1 (assoc group nnml-group-alist))))
(when active
(setcar active (or (and active-articles
(nconc rest articles)))
(deffoo nnml-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 " *nnml move*"))
+ (file-name-coding-system nnmail-pathname-coding-system)
result)
(nnml-possibly-change-directory group server)
(nnml-update-file-alist)
(let (nnml-current-directory
nnml-current-group
nnml-article-file-alist)
- (save-excursion
- (set-buffer buf)
+ (with-current-buffer buf
(insert-buffer-substring nntp-server-buffer)
(setq result (eval accept-form))
(kill-buffer (current-buffer))
(nnmail-check-syntax)
(let (result)
(when nnmail-cache-accepted-message-ids
- (nnmail-cache-insert (nnmail-fetch-field "message-id")))
+ (nnmail-cache-insert (nnmail-fetch-field "message-id")
+ group
+ (nnmail-fetch-field "subject")
+ (nnmail-fetch-field "from")))
(if (stringp group)
(and
(nnmail-activate 'nnml)
(setq result (car (nnml-save-mail
- (list (cons group (nnml-active-number group))))))
+ (list (cons group (nnml-active-number group
+ server)))
+ server t)))
(progn
(nnmail-save-active nnml-group-alist nnml-active-file)
(and last (nnml-save-nov))))
(and
(nnmail-activate 'nnml)
- (if (and (not (setq result (nnmail-article-group 'nnml-active-number)))
+ (if (and (not (setq result (nnmail-article-group
+ `(lambda (group)
+ (nnml-active-number group ,server)))))
(yes-or-no-p "Moved to `junk' group; delete article? "))
(setq result 'junk)
- (setq result (car (nnml-save-mail result))))
+ (setq result (car (nnml-save-mail result server t))))
(when last
(nnmail-save-active nnml-group-alist nnml-active-file)
(when nnmail-cache-accepted-message-ids
(deffoo nnml-request-replace-article (article group buffer)
(nnml-possibly-change-directory group)
- (save-excursion
- (set-buffer buffer)
+ (with-current-buffer buffer
(nnml-possibly-create-directory group)
(let ((chars (nnmail-insert-lines))
(art (concat (int-to-string article) "\t"))
t)
(setq headers (nnml-parse-head chars article))
;; Replace the NOV line in the NOV file.
- (save-excursion
- (set-buffer (nnml-open-nov group))
+ (with-current-buffer (nnml-open-nov group)
(goto-char (point-min))
(if (or (looking-at art)
(search-forward (concat "\n" art) nil t))
;; Delete the old NOV line.
- (delete-region (progn (beginning-of-line) (point))
- (progn (forward-line 1) (point)))
+ (gnus-delete-line)
;; The line isn't here, so we have to find out where
;; we should insert it. (This situation should never
;; occur, but one likes to make sure...)
(while (and (looking-at "[0-9]+\t")
- (< (string-to-int
+ (< (string-to-number
(buffer-substring
(match-beginning 0) (match-end 0)))
article)
(deffoo nnml-request-delete-group (group &optional force server)
(nnml-possibly-change-directory group server)
- (when force
- ;; Delete all articles in GROUP.
- (let ((articles
- (directory-files
- nnml-current-directory t
- (concat nnheader-numerical-short-files
- "\\|" (regexp-quote nnml-nov-file-name) "$"
- "\\|" (regexp-quote nnml-marks-file-name) "$")))
- article)
- (while articles
- (setq article (pop articles))
- (when (file-writable-p article)
- (nnheader-message 5 "Deleting article %s in %s..." article group)
- (funcall nnmail-delete-file-function article))))
- ;; Try to delete the directory itself.
- (ignore-errors (delete-directory nnml-current-directory)))
- ;; Remove the group from all structures.
- (setq nnml-group-alist
- (delq (assoc group nnml-group-alist) nnml-group-alist)
- nnml-current-group nil
- nnml-current-directory nil)
- ;; Save the active file.
- (nnmail-save-active nnml-group-alist nnml-active-file)
+ (let ((file (directory-file-name nnml-current-directory))
+ (file-name-coding-system nnmail-pathname-coding-system))
+ (if (file-exists-p file)
+ (if (file-directory-p file)
+ (progn
+ (when force
+ ;; Delete all articles in GROUP.
+ (let ((articles
+ (directory-files
+ nnml-current-directory t
+ (concat
+ nnheader-numerical-short-files
+ "\\|" (regexp-quote nnml-nov-file-name) "$"
+ "\\|" (regexp-quote nnml-marks-file-name) "$")))
+ (decoded (nnml-decoded-group-name group server)))
+ (dolist (article articles)
+ (when (file-writable-p article)
+ (nnheader-message 5 "Deleting article %s in %s..."
+ (file-name-nondirectory article)
+ decoded)
+ (funcall nnmail-delete-file-function article))))
+ ;; Try to delete the directory itself.
+ (ignore-errors (delete-directory nnml-current-directory))))
+ (nnheader-report 'nnml "%s is not a directory" file))
+ (nnheader-report 'nnml "No such directory: %s/" file))
+ ;; Remove the group from all structures.
+ (setq nnml-group-alist
+ (delq (assoc group nnml-group-alist) nnml-group-alist)
+ nnml-current-group nil
+ nnml-current-directory nil)
+ ;; Save the active file.
+ (nnmail-save-active nnml-group-alist nnml-active-file))
t)
(deffoo nnml-request-rename-group (group new-name &optional server)
(nnml-possibly-change-directory group server)
- (let ((new-dir (nnmail-group-pathname new-name nnml-directory))
- (old-dir (nnmail-group-pathname group nnml-directory)))
+ (let ((new-dir (nnml-group-pathname new-name nil server))
+ (old-dir (nnml-group-pathname group nil server))
+ (file-name-coding-system nnmail-pathname-coding-system))
(when (ignore-errors
(make-directory new-dir t)
t)
;; We move the articles file by file instead of renaming
;; the directory -- there may be subgroups in this group.
;; One might be more clever, I guess.
- (let ((files (nnml-article-to-file-alist old-dir)))
- (while files
- (rename-file
- (concat old-dir (cdar files))
- (concat new-dir (cdar files)))
- (pop files)))
+ (dolist (file (nnheader-article-to-file-alist old-dir))
+ (rename-file
+ (concat old-dir (cdr file))
+ (concat new-dir (cdr file))))
;; Move .overview file.
(let ((overview (concat old-dir nnml-nov-file-name)))
(when (file-exists-p overview)
(defun nnml-article-to-file (article)
(nnml-update-file-alist)
(let (file)
- (if (setq file (cdr (assq article nnml-article-file-alist)))
+ (if (setq file
+ (if nnml-use-compressed-files
+ (cdr (assq article nnml-article-file-alist))
+ (number-to-string article)))
(expand-file-name file nnml-current-directory)
- (if nnml-check-directory-twice
- ;; Just to make sure nothing went wrong when reading over NFS --
- ;; check once more.
- (when (file-exists-p
- (setq file (expand-file-name (number-to-string article)
- nnml-current-directory)))
- (nnml-update-file-alist t)
- file)))))
+ (when (not nnheader-directory-files-is-safe)
+ ;; Just to make sure nothing went wrong when reading over NFS --
+ ;; check once more.
+ (when (file-exists-p
+ (setq file (expand-file-name (number-to-string article)
+ nnml-current-directory)))
+ (nnml-update-file-alist t)
+ file)))))
(defun nnml-deletable-article-p (group article)
"Say whether ARTICLE in GROUP can be deleted."
- (let (path)
+ (let ((file-name-coding-system nnmail-pathname-coding-system)
+ path)
(when (setq path (nnml-article-to-file article))
(when (file-writable-p path)
(or (not nnmail-keep-last-article)
article)))))))
;; Find an article number in the current group given the Message-ID.
-(defun nnml-find-group-number (id)
- (save-excursion
- (set-buffer (get-buffer-create " *nnml id*"))
+(defun nnml-find-group-number (id server)
+ (with-current-buffer (get-buffer-create " *nnml id*")
(let ((alist nnml-group-alist)
number)
;; We want to look through all .overview files, but we want to
;; start with the one in the current directory. It seems most
;; likely that the article we are looking for is in that group.
- (if (setq number (nnml-find-id nnml-current-group id))
+ (if (setq number (nnml-find-id nnml-current-group id server))
(cons nnml-current-group number)
;; It wasn't there, so we look through the other groups as well.
(while (and (not number)
alist)
(or (string= (caar alist) nnml-current-group)
- (setq number (nnml-find-id (caar alist) id)))
+ (setq number (nnml-find-id (caar alist) id server)))
(or number
(setq alist (cdr alist))))
(and number
(cons (caar alist) number))))))
-(defun nnml-find-id (group id)
+(defun nnml-find-id (group id server)
(erase-buffer)
- (let ((nov (expand-file-name nnml-nov-file-name
- (nnmail-group-pathname group nnml-directory)))
+ (let ((nov (nnml-group-pathname group nnml-nov-file-name server))
number found)
(when (file-exists-p nov)
(nnheader-insert-file-contents nov)
(search-forward id nil t)) ; We find the ID.
;; And the id is in the fourth field.
(if (not (and (search-backward "\t" nil t 4)
- (not (search-backward"\t" (gnus-point-at-bol) t))))
+ (not (search-backward "\t" (point-at-bol) t))))
(forward-line 1)
(beginning-of-line)
(setq found t)
nil
(let ((nov (expand-file-name nnml-nov-file-name nnml-current-directory)))
(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
(nnml-open-server server))
(if (not group)
t
- (let ((pathname (nnmail-group-pathname group nnml-directory))
+ (let ((pathname (nnml-group-pathname group nil server))
(file-name-coding-system nnmail-pathname-coding-system))
(when (not (equal pathname nnml-current-directory))
(setq nnml-current-directory pathname
nnml-article-file-alist nil))
projects / gnus / blobdiff