;;; 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 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.
;; 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.
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
;;; Commentary:
(require 'nnoo)
(eval-when-compile (require 'cl))
+(eval-and-compile
+ (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 comression 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)
(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"))
(when (and (setq group-num (nnml-find-group-number id))
(cdr
(assq (cdr group-num)
- (nnml-article-to-file-alist
+ (nnheader-article-to-file-alist
(setq gpath
(nnmail-group-pathname
(car group-num)
(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))
(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.
+ (unless (eq nnmail-expiry-target 'delete)
+ (with-temp-buffer
+ (nnml-request-article number group server (current-buffer))
+ (let (nnml-current-directory
+ nnml-current-group
+ nnml-article-file-alist)
+ (nnmail-expiry-target-group nnmail-expiry-target group)))
+ ;; Maybe directory is changed during nnmail-expiry-target-group.
+ (nnml-possibly-change-directory group server))
+ (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)))
(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*"))
result)
(nnml-possibly-change-directory group server)
(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)
(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)
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))
+ "\\|" (regexp-quote nnml-marks-file-name) "$"))))
+ (dolist (article articles)
(when (file-writable-p article)
(nnheader-message 5 "Deleting article %s in %s..." article group)
(funcall nnmail-delete-file-function article))))
;; 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."
(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)
(defun nnml-save-mail (group-art)
"Called narrowed to an article."
- (let (chars headers)
+ (let (chars headers extension)
(setq chars (nnmail-insert-lines))
+ (setq extension
+ (and nnml-use-compressed-files
+ (> chars nnml-compressed-files-size-threshold)
+ (if (stringp nnml-use-compressed-files)
+ nnml-use-compressed-files
+ ".gz")))
(nnmail-insert-xref group-art)
(run-hooks 'nnmail-prepare-save-mail-hook)
(run-hooks 'nnml-prepare-save-mail-hook)
(nnml-possibly-create-directory (caar ga))
(let ((file (concat (nnmail-group-pathname
(caar ga) nnml-directory)
- (int-to-string (cdar ga)))))
+ (int-to-string (cdar ga))
+ extension)))
(if first
;; It was already saved, so we just make a hard link.
(funcall nnmail-crosspost-link-function first file t)
(unless nnml-article-file-alist
(setq nnml-article-file-alist
(sort
- (nnml-article-to-file-alist nnml-current-directory)
+ (nnml-current-group-article-to-file-alist)
'car-less-than-car)))
(setq active
(if nnml-article-file-alist
(nnheader-insert-nov headers)))
(defsubst nnml-header-value ()
- (buffer-substring (match-end 0) (progn (end-of-line) (point))))
+ (buffer-substring (match-end 0) (point-at-eol)))
(defun nnml-parse-head (chars &optional number)
"Parse the head of the current buffer."
(unless (zerop (buffer-size))
(narrow-to-region
(goto-char (point-min))
- (if (search-forward "\n\n" nil t) (1- (point)) (point-max))))
- ;; Fold continuation lines.
- (goto-char (point-min))
- (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
- (replace-match " " t t))
- ;; Remove any tabs; they are too confusing.
- (subst-char-in-region (point-min) (point-max) ?\t ? )
- (let ((headers (nnheader-parse-head t)))
+ (if (re-search-forward "\n\r?\n" nil t)
+ (1- (point))
+ (point-max))))
+ (let ((headers (nnheader-parse-naked-head)))
(mail-header-set-chars headers chars)
(mail-header-set-number headers number)
headers))))
(when (buffer-name (cdar nnml-nov-buffer-alist))
(set-buffer (cdar nnml-nov-buffer-alist))
(when (buffer-modified-p)
- (nnmail-write-region 1 (point-max) nnml-nov-buffer-file-name
- nil 'nomesg))
+ (nnmail-write-region (point-min) (point-max)
+ nnml-nov-buffer-file-name nil 'nomesg))
(set-buffer-modified-p nil)
(kill-buffer (current-buffer)))
(setq nnml-nov-buffer-alist (cdr nnml-nov-buffer-alist)))))
(unless (member (file-truename dir) seen)
(push (file-truename dir) seen)
;; We descend recursively
- (let ((dirs (directory-files dir t nil t))
- dir)
- (while (setq dir (pop dirs))
- (when (and (not (string-match "^\\." (file-name-nondirectory dir)))
- (file-directory-p dir))
- (nnml-generate-nov-databases-1 dir seen))))
+ (dolist (dir (directory-files dir t nil t))
+ (when (and (not (string-match "^\\." (file-name-nondirectory dir)))
+ (file-directory-p dir))
+ (nnml-generate-nov-databases-1 dir seen)))
;; Do this directory.
(let ((files (sort (nnheader-article-to-file-alist dir)
'car-less-than-car)))
(push (list group
(cons (or (caar files) (1+ last))
(max last
- (or (let ((f files))
- (while (cdr f) (setq f (cdr f)))
- (caar f))
+ (or (caar (last files))
0))))
nnml-group-alist)))
(narrow-to-region
(goto-char (point-min))
(progn
- (search-forward "\n\n" nil t)
+ (re-search-forward "\n\r?\n" nil t)
(setq chars (- (point-max) (point)))
- (max 1 (1- (point)))))
+ (max (point-min) (1- (point)))))
(unless (zerop (buffer-size))
(goto-char (point-min))
(setq headers (nnml-parse-head chars (caar files)))
(setq files (cdr files)))
(save-excursion
(set-buffer nov-buffer)
- (nnmail-write-region 1 (point-max) nov nil 'nomesg)
+ (nnmail-write-region (point-min) (point-max) nov nil 'nomesg)
(kill-buffer (current-buffer))))))
(defun nnml-nov-delete-article (group article)
t))
(defun nnml-update-file-alist (&optional force)
- (when (or (not nnml-article-file-alist)
- force)
- (setq nnml-article-file-alist
- (nnml-article-to-file-alist nnml-current-directory))))
+ (when nnml-use-compressed-files
+ (when (or (not nnml-article-file-alist)
+ force)
+ (setq nnml-article-file-alist
+ (nnml-current-group-article-to-file-alist)))))
(defun nnml-directory-articles (dir)
"Return a list of all article files in a directory.
(forward-line 1))
list))))
-(defun nnml-article-to-file-alist (dir)
- "Return an alist of article/file pairs in DIR.
-Use the nov database for that directory if available."
- (if (or gnus-nov-is-evil nnml-nov-is-evil
+(defun nnml-current-group-article-to-file-alist ()
+ "Return an alist of article/file pairs in the current group.
+Use the nov database for the current group if available."
+ (if (or nnml-use-compressed-files
+ gnus-nov-is-evil
+ nnml-nov-is-evil
(not (file-exists-p
(expand-file-name nnml-nov-file-name
nnml-current-directory))))
;; build list from .overview if available
(save-excursion
(let ((alist nil)
- art
- (buffer (nnml-get-nov-buffer nnml-current-group)))
+ (buffer (nnml-get-nov-buffer nnml-current-group))
+ art)
(set-buffer buffer)
(goto-char (point-min))
(while (not (eobp))
(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 nnml-marks (gnus-update-alist-soft
(deffoo nnml-request-update-info (group info &optional server)
(nnml-possibly-change-directory group server)
- (unless nnml-marks-is-evil
+ (when (and (not nnml-marks-is-evil) (nnml-marks-changed-p group))
(nnheader-message 8 "Updating marks for %s..." group)
(nnml-open-marks group server)
;; Update info using `nnml-marks'.
- (mapcar (lambda (pred)
+ (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) nnml-marks))
(gnus-info-marks info))
- t))
- gnus-article-mark-lists)
+ t)))
+ gnus-article-mark-lists)
(let ((seen (cdr (assq 'read nnml-marks))))
(gnus-info-set-read info
(if (and (integerp (car seen))
(null (cdr seen)))
(list (cons (car seen) (car seen)))
- seen))))
+ seen)))
+ (nnheader-message 8 "Updating marks for %s...done" group))
info)
+(defun nnml-marks-changed-p (group)
+ (let ((file (expand-file-name nnml-marks-file-name
+ (nnmail-group-pathname group nnml-directory))))
+ (if (null (gnus-gethash file nnml-marks-modtime))
+ t ;; never looked at marks file, assume it has changed
+ (not (equal (gnus-gethash file nnml-marks-modtime)
+ (nth 5 (file-attributes file)))))))
+
(defun nnml-save-marks (group server)
(let ((file-name-coding-system nnmail-pathname-coding-system)
(file (expand-file-name nnml-marks-file-name
(nnml-possibly-create-directory group)
(with-temp-file file
(erase-buffer)
- (princ nnml-marks (current-buffer))
- (insert "\n")))
+ (gnus-prin1 nnml-marks)
+ (insert "\n"))
+ (gnus-sethash file
+ (nth 5 (file-attributes file))
+ nnml-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 nnml-open-marks (group server)
- (let ((file (expand-file-name
- nnml-marks-file-name
+ (let ((file (expand-file-name
+ nnml-marks-file-name
(nnmail-group-pathname group nnml-directory))))
(if (file-exists-p file)
- (setq nnml-marks (condition-case err
- (with-temp-buffer
- (nnheader-insert-file-contents file)
- (read (current-buffer)))
- (error (or (gnus-yes-or-no-p
- (format "Error reading nnml marks file %s (%s). Continuing will use marks from .newsrc.eld. Continue? " file err))
- (error "Cannot read nnml marks file %s (%s)" file err)))))
+ (condition-case err
+ (with-temp-buffer
+ (gnus-sethash file (nth 5 (file-attributes file))
+ nnml-marks-modtime)
+ (nnheader-insert-file-contents file)
+ (setq nnml-marks (read (current-buffer)))
+ (dolist (el gnus-article-unpropagated-mark-lists)
+ (setq nnml-marks (gnus-remassoc el nnml-marks))))
+ (error (or (gnus-yes-or-no-p
+ (format "Error reading nnml marks file %s (%s). Continuing will use marks from .newsrc.eld. Continue? " file err))
+ (error "Cannot read nnml marks file %s (%s)" file err))))
;; User didn't have a .marks file. Probably first time
;; user of the .marks stuff. Bootstrap it from .newsrc.eld.
(let ((info (gnus-get-info
(nnheader-message 7 "Bootstrapping marks for %s..." group)
(setq nnml-marks (gnus-info-marks info))
(push (cons 'read (gnus-info-read info)) nnml-marks)
- (nnml-save-marks group server)))))
+ (dolist (el gnus-article-unpropagated-mark-lists)
+ (setq nnml-marks (gnus-remassoc el nnml-marks)))
+ (nnml-save-marks group server)
+ (nnheader-message 7 "Bootstrapping marks for %s...done" group)))))
+
+
+;;;
+;;; Group and server compaction. -- dvl
+;;;
+
+;; #### FIXME: this function handles self Xref: entry correctly, but I don't
+;; #### know how to handle external cross-references. I actually don't know if
+;; #### this is handled correctly elsewhere. For instance, what happens if you
+;; #### move all articles to a new group (that's what people do for manual
+;; #### compaction) ?
+
+;; #### NOTE: the function below handles the article backlog. This is
+;; #### conceptually the wrong place to do it because the backend is at a
+;; #### lower level. However, this is the only place where we have the needed
+;; #### information to do the job. Ideally, this function should not handle
+;; #### the backlog by itself, but return a list of moved groups / articles to
+;; #### the caller. This will become important to avoid code duplication when
+;; #### other backends get a compaction feature. Also, note that invalidating
+;; #### the "original article buffer" is already done at an upper level.
+
+(defun nnml-request-compact-group (group &optional server save)
+ (nnml-possibly-change-directory group server)
+ (unless nnml-article-file-alist
+ (setq nnml-article-file-alist
+ (sort (nnml-current-group-article-to-file-alist)
+ 'car-less-than-car)))
+ (if (not nnml-article-file-alist)
+ ;; The group is empty: do nothing but return t
+ t
+ ;; The group is not empty:
+ (let* ((group-full-name
+ (gnus-group-prefixed-name
+ group
+ (gnus-server-to-method (format "nnml:%s" server))))
+ (info (gnus-get-info group-full-name))
+ (new-number 1)
+ compacted)
+ (let ((articles nnml-article-file-alist)
+ article)
+ (while (setq article (pop articles))
+ (let ((old-number (car article)))
+ (when (> old-number new-number)
+ ;; There is a gap here:
+ (let ((old-number-string (int-to-string old-number))
+ (new-number-string (int-to-string new-number)))
+ (setq compacted t)
+ ;; #### NOTE: `nnml-article-to-file' calls
+ ;; #### `nnml-update-file-alist' (which in turn calls
+ ;; #### `nnml-current-group-article-to-file-alist', which
+ ;; #### might use the NOV database). This might turn out to be
+ ;; #### inefficient. In that case, we will do the work
+ ;; #### manually.
+ ;; 1/ Move the article to a new file:
+ (let* ((oldfile (nnml-article-to-file old-number))
+ (newfile
+ (gnus-replace-in-string
+ oldfile (concat "\\("
+ old-number-string
+ "\\)\\(\\(\\.gz\\)?\\)$")
+ (concat new-number-string "\\2"))))
+ (with-current-buffer nntp-server-buffer
+ (nnmail-find-file oldfile)
+ ;; Update the Xref header in the article itself:
+ (when (and (re-search-forward "^Xref: [^ ]+ " nil t)
+ (re-search-forward
+ (concat "\\<"
+ (regexp-quote
+ (concat group ":" old-number-string))
+ "\\>")
+ (point-at-eol) t))
+ (replace-match
+ (concat group ":" new-number-string)))
+ ;; Save to the new file:
+ (nnmail-write-region (point-min) (point-max) newfile))
+ (funcall nnmail-delete-file-function oldfile))
+ ;; 2/ Update all marks for this article:
+ ;; #### NOTE: it is possible that the new article number
+ ;; #### already belongs to a range, whereas the corresponding
+ ;; #### article doesn't exist (for example, if you delete an
+ ;; #### article). For that reason, it is important to update
+ ;; #### the ranges (meaning remove inexistant articles) before
+ ;; #### doing anything on them.
+ ;; 2 a/ read articles:
+ (let ((read (gnus-info-read info)))
+ (setq read (gnus-remove-from-range read (list new-number)))
+ (when (gnus-member-of-range old-number read)
+ (setq read (gnus-remove-from-range read (list old-number)))
+ (setq read (gnus-add-to-range read (list new-number))))
+ (gnus-info-set-read info read))
+ ;; 2 b/ marked articles:
+ (let ((oldmarks (gnus-info-marks info))
+ mark newmarks)
+ (while (setq mark (pop oldmarks))
+ (setcdr mark (gnus-remove-from-range (cdr mark)
+ (list new-number)))
+ (when (gnus-member-of-range old-number (cdr mark))
+ (setcdr mark (gnus-remove-from-range (cdr mark)
+ (list old-number)))
+ (setcdr mark (gnus-add-to-range (cdr mark)
+ (list new-number))))
+ (push mark newmarks))
+ (gnus-info-set-marks info newmarks))
+ ;; 3/ Update the NOV entry for this article:
+ (unless nnml-nov-is-evil
+ (save-excursion
+ (set-buffer (nnml-open-nov group))
+ (when (nnheader-find-nov-line old-number)
+ ;; Replace the article number:
+ (looking-at old-number-string)
+ (replace-match new-number-string nil t)
+ ;; Update the Xref header:
+ (when (re-search-forward
+ (concat "\\(Xref:[^\t\n]* \\)\\<"
+ (regexp-quote
+ (concat group ":" old-number-string))
+ "\\>")
+ (point-at-eol) t)
+ (replace-match
+ (concat "\\1" group ":" new-number-string))))))
+ ;; 4/ Possibly remove the article from the backlog:
+ (when gnus-keep-backlog
+ ;; #### NOTE: instead of removing the article, we could
+ ;; #### modify the backlog to reflect the numbering change,
+ ;; #### but I don't think it's worth it.
+ (gnus-backlog-remove-article group-full-name old-number)
+ (gnus-backlog-remove-article group-full-name new-number))))
+ (setq new-number (1+ new-number)))))
+ (if (not compacted)
+ ;; No compaction had to be done:
+ t
+ ;; Some articles have actually been renamed:
+ ;; 1/ Rebuild active information:
+ (let ((entry (assoc group nnml-group-alist))
+ (active (cons 1 (1- new-number))))
+ (setq nnml-group-alist (delq entry nnml-group-alist))
+ (push (list group active) nnml-group-alist)
+ ;; Update the active hashtable to let the *Group* buffer display
+ ;; up-to-date lines. I don't think that either gnus-newsrc-hashtb or
+ ;; gnus-newwrc-alist are out of date, since all we did is to modify
+ ;; the info of the group internally.
+ (gnus-set-active group-full-name active))
+ ;; 1 bis/
+ ;; #### NOTE: normally, we should save the overview (NOV) file
+ ;; #### here, just like we save the marks file. However, there is no
+ ;; #### such function as nnml-save-nov for a single group. Only for
+ ;; #### all groups. Gnus inconsistency is getting worse every day...
+ ;; 2/ Rebuild marks file:
+ (unless nnml-marks-is-evil
+ ;; #### NOTE: this constant use of global variables everywhere is
+ ;; #### truly disgusting. Gnus really needs a *major* cleanup.
+ (setq nnml-marks (gnus-info-marks info))
+ (push (cons 'read (gnus-info-read info)) nnml-marks)
+ (dolist (el gnus-article-unpropagated-mark-lists)
+ (setq nnml-marks (gnus-remassoc el nnml-marks)))
+ (nnml-save-marks group server))
+ ;; 3/ Save everything if this was not part of a bigger operation:
+ (if (not save)
+ ;; Nothing to save (yet):
+ t
+ ;; Something to save:
+ ;; a/ Save the NOV databases:
+ ;; #### NOTE: this should be done directory per directory in 1bis
+ ;; #### above. See comment there.
+ (nnml-save-nov)
+ ;; b/ Save the active file:
+ (nnmail-save-active nnml-group-alist nnml-active-file)
+ t)))))
+
+(defun nnml-request-compact (&optional server)
+ "Request compaction of all SERVER nnml groups."
+ (interactive (list (or (nnoo-current-server 'nnml) "")))
+ (nnmail-activate 'nnml)
+ (unless (nnml-server-opened server)
+ (nnml-open-server server))
+ (setq nnml-directory (expand-file-name nnml-directory))
+ (let* ((groups (gnus-groups-from-server
+ (gnus-server-to-method (format "nnml:%s" server))))
+ (first (pop groups))
+ group)
+ (when first
+ (while (setq group (pop groups))
+ (nnml-request-compact-group (gnus-group-real-name group) server))
+ (nnml-request-compact-group (gnus-group-real-name first) server t))))
+
(provide 'nnml)
+;;; arch-tag: 52c97dc3-9735-45de-b439-9e4d23b52004
;;; nnml.el ends here
projects / gnus / blobdiff