X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fnnmaildir.el;h=74a693a9c6122b0c65e490bbe1275233cac8b9aa;hp=79321dcdf42c16a06995288bb23b1cb13985aa18;hb=d6d90fbbda04a990e100832c709d6c746d872aa3;hpb=afae98bbfe7278fb7e42a26eb9a720befa97c3c3 diff --git a/lisp/nnmaildir.el b/lisp/nnmaildir.el index 79321dcdf..74a693a9c 100644 --- a/lisp/nnmaildir.el +++ b/lisp/nnmaildir.el @@ -1,14 +1,15 @@ ;;; nnmaildir.el --- maildir backend for Gnus -;; Public domain. + +;; This file is in the public domain. ;; Author: Paul Jarc ;; 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 @@ -16,37 +17,52 @@ ;; 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: -;; Maildir format is documented in the maildir(5) man page from qmail -;; (available at ) and at -;; . nnmaildir also stores +;; Maildir format is documented at +;; and in the maildir(5) man page from qmail (available at +;; ). nnmaildir also stores ;; extra information in the .nnmaildir/ directory within a maildir. ;; ;; Some goals of nnmaildir: -;; * Everything Just Works, and correctly. E.g., stale NOV data is -;; ignored; no need for -generate-nov-databases. -;; * Perfect reliability: [C-g] will never corrupt its data in memory, -;; and SIGKILL will never corrupt its data in the filesystem. +;; * Everything Just Works, and correctly. E.g., NOV data is automatically +;; regenerated when stale; no need for manually running +;; *-generate-nov-databases. +;; * Perfect reliability: [C-g] will never corrupt its data in memory, and +;; SIGKILL will never corrupt its data in the filesystem. +;; * Allow concurrent operation as much as possible. If files change out +;; from under us, adapt to the changes or degrade gracefully. ;; * We use the filesystem as a database, so that, e.g., it's easy to ;; manipulate marks from outside Gnus. -;; * All information about a group is stored in the maildir, for easy -;; backup, copying, restoring, etc. +;; * All information about a group is stored in the maildir, for easy backup, +;; copying, restoring, etc. ;; ;; Todo: -;; * Don't force article renumbering, so nnmaildir can be used with -;; the cache and agent. Alternatively, completely rewrite the Gnus -;; backend interface, which would have other advantages as well. -;; -;; See also until that -;; information is added to the Gnus manual. +;; * When moving an article for expiry, copy all the marks except 'expire +;; from the original article. +;; * Add a hook for when moving messages from new/ to cur/, to support +;; nnmail's duplicate detection. +;; * Improve generated Xrefs, so crossposts are detectable. +;; * Improve code readability. ;;; Code: +;; eval this before editing +[(progn + (put 'nnmaildir--with-nntp-buffer 'lisp-indent-function 0) + (put 'nnmaildir--with-work-buffer 'lisp-indent-function 0) + (put 'nnmaildir--with-nov-buffer 'lisp-indent-function 0) + (put 'nnmaildir--with-move-buffer 'lisp-indent-function 0) + (put 'nnmaildir--condcase 'lisp-indent-function 2) + ) +] + +;; For Emacs <22.2 and XEmacs. +(eval-and-compile + (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) + (eval-and-compile (require 'nnheader) (require 'gnus) @@ -61,6 +77,56 @@ (defconst nnmaildir-version "Gnus") +(defconst nnmaildir-flag-mark-mapping + '((?F . tick) + (?R . reply) + (?S . read)) + "Alist mapping Maildir filename flags to Gnus marks. +Maildir filenames are of the form \"unique-id:2,FLAGS\", +where FLAGS are a string of characters in ASCII order. +Some of the FLAGS correspond to Gnus marks.") + +(defsubst nnmaildir--mark-to-flag (mark) + "Find the Maildir flag that corresponds to MARK (an atom). +Return a character, or `nil' if not found. +See `nnmaildir-flag-mark-mapping'." + (car (rassq mark nnmaildir-flag-mark-mapping))) + +(defsubst nnmaildir--flag-to-mark (flag) + "Find the Gnus mark that corresponds to FLAG (a character). +Return an atom, or `nil' if not found. +See `nnmaildir-flag-mark-mapping'." + (cdr (assq flag nnmaildir-flag-mark-mapping))) + +(defun nnmaildir--ensure-suffix (filename) + "Ensure that FILENAME contains the suffix \":2,\"." + (if (gnus-string-match-p ":2," filename) + filename + (concat filename ":2,"))) + +(defun nnmaildir--add-flag (flag suffix) + "Return a copy of SUFFIX where FLAG is set. +SUFFIX should start with \":2,\"." + (unless (gnus-string-match-p "^:2," suffix) + (error "Invalid suffix `%s'" suffix)) + (let* ((flags (substring suffix 3)) + (flags-as-list (append flags nil)) + (new-flags + (concat (gnus-delete-duplicates + ;; maildir flags must be sorted + (sort (cons flag flags-as-list) '<))))) + (concat ":2," new-flags))) + +(defun nnmaildir--remove-flag (flag suffix) + "Return a copy of SUFFIX where FLAG is cleared. +SUFFIX should start with \":2,\"." + (unless (gnus-string-match-p "^:2," suffix) + (error "Invalid suffix `%s'" suffix)) + (let* ((flags (substring suffix 3)) + (flags-as-list (append flags nil)) + (new-flags (concat (delq flag flags-as-list)))) + (concat ":2," new-flags))) + (defvar nnmaildir-article-file-name nil "*The filename of the most recently requested article. This variable is set by nnmaildir-request-article.") @@ -70,8 +136,8 @@ by nnmaildir-request-article.") ;; Variables to generate filenames of messages being delivered: (defvar nnmaildir--delivery-time "") -(defconst nnmaildir--delivery-pid (number-to-string (emacs-pid))) -(defvar nnmaildir--delivery-ct nil) +(defconst nnmaildir--delivery-pid (concat "P" (number-to-string (emacs-pid)))) +(defvar nnmaildir--delivery-count nil) ;; An obarry containing symbols whose names are server names and whose values ;; are servers: @@ -82,7 +148,7 @@ by nnmaildir-request-article.") ;; A copy of nnmail-extra-headers (defvar nnmaildir--extra nil) -;; A disk NOV structure (must be prin1-able, so no defstruct) looks like this: +;; A NOV structure looks like this (must be prin1-able, so no defstruct): ["subject\tfrom\tdate" "references\tchars\lines" "To: you\tIn-Reply-To: " @@ -109,40 +175,80 @@ by nnmaildir-request-article.") (msgid nil :type string) ;; "" (nov nil :type vector)) ;; cached nov structure, or nil -(defstruct nnmaildir--lists +(defstruct nnmaildir--grp + (name nil :type string) ;; "group.name" + (new nil :type list) ;; new/ modtime + (cur nil :type list) ;; cur/ modtime + (min 1 :type natnum) ;; minimum article number + (count 0 :type natnum) ;; count of articles (nlist nil :type list) ;; list of articles, ordered descending by number (flist nil :type vector) ;; obarray mapping filename prefix->article - (mlist nil :type vector)) ;; obarray mapping message-id->article - -(defstruct nnmaildir--grp - (name nil :type string) ;; "group.name" - (new nil :type list) ;; new/ modtime - (cur nil :type list) ;; cur/ modtime - (lists nil :type nnmaildir--lists) ;; lists of articles in this group - (cache nil :type vector) ;; nov cache - (index nil :type natnum) ;; index of next cache entry to replace - (mmth nil :type vector)) ;; obarray mapping mark name->dir modtime + (mlist nil :type vector) ;; obarray mapping message-id->article + (cache nil :type vector) ;; nov cache + (index nil :type natnum) ;; index of next cache entry to replace + (mmth nil :type vector)) ;; obarray mapping mark name->dir modtime + ; ("Mark Mod Time Hash") (defstruct nnmaildir--srv - (address nil :type string) ;; server address string - (method nil :type list) ;; (nnmaildir "address" ...) - (prefix nil :type string) ;; "nnmaildir+address:" - (dir nil :type string) ;; "/expanded/path/to/server/dir/" - (ls nil :type function) ;; directory-files function - (groups nil :type vector) ;; obarray mapping group names->groups - (curgrp nil :type nnmaildir--grp) ;; current group, or nil - (error nil :type string) ;; last error message, or nil - (mtime nil :type list) ;; modtime of dir - (gnm nil) ;; flag: split from mail-sources? - (create-dir nil :type string)) ;; group creation directory - -(defmacro nnmaildir--nlist-last-num (nlist) - `(let ((nlist ,nlist)) - (if nlist (nnmaildir--art-num (car nlist)) 0))) -(defmacro nnmaildir--nlist-art (nlist num) ;;;; evals args multiple times - `(and ,nlist - (>= (nnmaildir--art-num (car ,nlist)) ,num) - (nth (- (nnmaildir--art-num (car ,nlist)) ,num) ,nlist))) + (address nil :type string) ;; server address string + (method nil :type list) ;; (nnmaildir "address" ...) + (prefix nil :type string) ;; "nnmaildir+address:" + (dir nil :type string) ;; "/expanded/path/to/server/dir/" + (ls nil :type function) ;; directory-files function + (groups nil :type vector) ;; obarray mapping group name->group + (curgrp nil :type nnmaildir--grp) ;; current group, or nil + (error nil :type string) ;; last error message, or nil + (mtime nil :type list) ;; modtime of dir + (gnm nil) ;; flag: split from mail-sources? + (target-prefix nil :type string)) ;; symlink target prefix + +(defun nnmaildir--article-set-flags (article new-suffix curdir) + (let* ((prefix (nnmaildir--art-prefix article)) + (suffix (nnmaildir--art-suffix article)) + (article-file (concat curdir prefix suffix)) + (new-name (concat curdir prefix new-suffix))) + (unless (file-exists-p article-file) + (error "Couldn't find article file %s" article-file)) + (rename-file article-file new-name 'replace) + (setf (nnmaildir--art-suffix article) new-suffix))) + +(defun nnmaildir--expired-article (group article) + (setf (nnmaildir--art-nov article) nil) + (let ((flist (nnmaildir--grp-flist group)) + (mlist (nnmaildir--grp-mlist group)) + (min (nnmaildir--grp-min group)) + (count (1- (nnmaildir--grp-count group))) + (prefix (nnmaildir--art-prefix article)) + (msgid (nnmaildir--art-msgid article)) + (new-nlist nil) + (nlist-pre '(nil . nil)) + nlist-post num) + (unless (zerop count) + (setq nlist-post (nnmaildir--grp-nlist group) + num (nnmaildir--art-num article)) + (if (eq num (caar nlist-post)) + (setq new-nlist (cdr nlist-post)) + (setq new-nlist nlist-post + nlist-pre nlist-post + nlist-post (cdr nlist-post)) + (while (/= num (caar nlist-post)) + (setq nlist-pre nlist-post + nlist-post (cdr nlist-post))) + (setq nlist-post (cdr nlist-post)) + (if (eq num min) + (setq min (caar nlist-pre))))) + (let ((inhibit-quit t)) + (setf (nnmaildir--grp-min group) min) + (setf (nnmaildir--grp-count group) count) + (setf (nnmaildir--grp-nlist group) new-nlist) + (setcdr nlist-pre nlist-post) + (unintern prefix flist) + (unintern msgid mlist)))) + +(defun nnmaildir--nlist-art (group num) + (let ((entry (assq num (nnmaildir--grp-nlist group)))) + (if entry + (cdr entry)))) (defmacro nnmaildir--flist-art (list file) `(symbol-value (intern-soft ,file ,list))) (defmacro nnmaildir--mlist-art (list msgid) @@ -157,37 +263,38 @@ by nnmaildir-request-article.") gname))) (defun nnmaildir--param (pgname param) - (setq param (gnus-group-find-parameter pgname param 'allow-list) - param (if (vectorp param) (aref param 0) param)) + (setq param (gnus-group-find-parameter pgname param 'allow-list)) + (if (vectorp param) (setq param (aref param 0))) (eval param)) (defmacro nnmaildir--with-nntp-buffer (&rest body) - `(save-excursion - (set-buffer nntp-server-buffer) + (declare (debug (body))) + `(with-current-buffer nntp-server-buffer ,@body)) (defmacro nnmaildir--with-work-buffer (&rest body) - `(save-excursion - (set-buffer (get-buffer-create " *nnmaildir work*")) + (declare (debug (body))) + `(with-current-buffer (get-buffer-create " *nnmaildir work*") ,@body)) (defmacro nnmaildir--with-nov-buffer (&rest body) - `(save-excursion - (set-buffer (get-buffer-create " *nnmaildir nov*")) + (declare (debug (body))) + `(with-current-buffer (get-buffer-create " *nnmaildir nov*") ,@body)) (defmacro nnmaildir--with-move-buffer (&rest body) - `(save-excursion - (set-buffer (get-buffer-create " *nnmaildir move*")) + (declare (debug (body))) + `(with-current-buffer (get-buffer-create " *nnmaildir move*") ,@body)) -(defmacro nnmaildir--subdir (dir subdir) - `(file-name-as-directory (concat ,dir ,subdir))) -(defmacro nnmaildir--srvgrp-dir (srv-dir gname) - `(nnmaildir--subdir ,srv-dir ,gname)) -(defmacro nnmaildir--tmp (dir) `(nnmaildir--subdir ,dir "tmp")) -(defmacro nnmaildir--new (dir) `(nnmaildir--subdir ,dir "new")) -(defmacro nnmaildir--cur (dir) `(nnmaildir--subdir ,dir "cur")) -(defmacro nnmaildir--nndir (dir) `(nnmaildir--subdir ,dir ".nnmaildir")) -(defmacro nnmaildir--nov-dir (dir) `(nnmaildir--subdir ,dir "nov")) -(defmacro nnmaildir--marks-dir (dir) `(nnmaildir--subdir ,dir "marks")) +(defsubst nnmaildir--subdir (dir subdir) + (file-name-as-directory (concat dir subdir))) +(defsubst nnmaildir--srvgrp-dir (srv-dir gname) + (nnmaildir--subdir srv-dir gname)) +(defsubst nnmaildir--tmp (dir) (nnmaildir--subdir dir "tmp")) +(defsubst nnmaildir--new (dir) (nnmaildir--subdir dir "new")) +(defsubst nnmaildir--cur (dir) (nnmaildir--subdir dir "cur")) +(defsubst nnmaildir--nndir (dir) (nnmaildir--subdir dir ".nnmaildir")) +(defsubst nnmaildir--nov-dir (dir) (nnmaildir--subdir dir "nov")) +(defsubst nnmaildir--marks-dir (dir) (nnmaildir--subdir dir "marks")) +(defsubst nnmaildir--num-dir (dir) (nnmaildir--subdir dir "num")) (defmacro nnmaildir--unlink (file-arg) `(let ((file ,file-arg)) @@ -195,98 +302,197 @@ by nnmaildir-request-article.") (defun nnmaildir--mkdir (dir) (or (file-exists-p (file-name-as-directory dir)) (make-directory-internal (directory-file-name dir)))) - +(defun nnmaildir--mkfile (file) + (write-region "" nil file nil 'no-message)) +(defun nnmaildir--delete-dir-files (dir ls) + (when (file-attributes dir) + (mapc 'delete-file (funcall ls dir 'full "\\`[^.]" 'nosort)) + (delete-directory dir))) + +(defun nnmaildir--group-maxnum (server group) + (catch 'return + (if (zerop (nnmaildir--grp-count group)) (throw 'return 0)) + (let ((dir (nnmaildir--srvgrp-dir (nnmaildir--srv-dir server) + (nnmaildir--grp-name group))) + (number-opened 1) + attr ino-opened nlink number-linked) + (setq dir (nnmaildir--nndir dir) + dir (nnmaildir--num-dir dir)) + (while t + (setq attr (file-attributes + (concat dir (number-to-string number-opened)))) + (or attr (throw 'return (1- number-opened))) + (setq ino-opened (nth 10 attr) + nlink (nth 1 attr) + number-linked (+ number-opened nlink)) + (if (or (< nlink 1) (< number-linked nlink)) + (signal 'error '("Arithmetic overflow"))) + (setq attr (file-attributes + (concat dir (number-to-string number-linked)))) + (or attr (throw 'return (1- number-linked))) + (unless (equal ino-opened (nth 10 attr)) + (setq number-opened number-linked)))))) + +;; Make the given server, if non-nil, be the current server. Then make the +;; given group, if non-nil, be the current group of the current server. Then +;; return the group object for the current group. (defun nnmaildir--prepare (server group) (let (x groups) (catch 'return (if (null server) - (or (setq server nnmaildir--cur-server) - (throw 'return nil)) - (or (setq server (intern-soft server nnmaildir--servers)) + (unless (setq server nnmaildir--cur-server) (throw 'return nil)) + (unless (setq server (intern-soft server nnmaildir--servers)) + (throw 'return nil)) (setq server (symbol-value server) nnmaildir--cur-server server)) - (or (setq groups (nnmaildir--srv-groups server)) - (throw 'return nil)) - (if (nnmaildir--srv-method server) nil + (unless (setq groups (nnmaildir--srv-groups server)) + (throw 'return nil)) + (unless (nnmaildir--srv-method server) (setq x (concat "nnmaildir:" (nnmaildir--srv-address server)) x (gnus-server-to-method x)) - (or x (throw 'return nil)) + (unless x (throw 'return nil)) (setf (nnmaildir--srv-method server) x)) (if (null group) - (or (setq group (nnmaildir--srv-curgrp server)) - (throw 'return nil)) - (or (setq group (intern-soft group groups)) - (throw 'return nil)) + (unless (setq group (nnmaildir--srv-curgrp server)) + (throw 'return nil)) + (unless (setq group (intern-soft group groups)) + (throw 'return nil)) (setq group (symbol-value group))) group))) +(defun nnmaildir--tab-to-space (string) + (let ((pos 0)) + (while (string-match "\t" string pos) + (aset string (match-beginning 0) ? ) + (setq pos (match-end 0)))) + string) + +(defmacro nnmaildir--condcase (errsym body &rest handler) + (declare (debug (sexp form body))) + `(condition-case ,errsym + (let ((system-messages-locale "C")) ,body) + (error . ,handler))) + +(defun nnmaildir--emlink-p (err) + (and (eq (car err) 'file-error) + (string= (downcase (caddr err)) "too many links"))) + +(defun nnmaildir--enoent-p (err) + (and (eq (car err) 'file-error) + (string= (downcase (caddr err)) "no such file or directory"))) + +(defun nnmaildir--eexist-p (err) + (eq (car err) 'file-already-exists)) + +(defun nnmaildir--new-number (nndir) + "Allocate a new article number by atomically creating a file under NNDIR." + (let ((numdir (nnmaildir--num-dir nndir)) + (make-new-file t) + (number-open 1) + number-link previous-number-link path-open path-link ino-open) + (nnmaildir--mkdir numdir) + (catch 'return + (while t + (setq path-open (concat numdir (number-to-string number-open))) + (if (not make-new-file) + (setq previous-number-link number-link) + (nnmaildir--mkfile path-open) + ;; If Emacs had O_CREAT|O_EXCL, we could return number-open here. + (setq make-new-file nil + previous-number-link 0)) + (let* ((attr (file-attributes path-open)) + (nlink (nth 1 attr))) + (setq ino-open (nth 10 attr) + number-link (+ number-open nlink)) + (if (or (< nlink 1) (< number-link nlink)) + (signal 'error '("Arithmetic overflow")))) + (if (= number-link previous-number-link) + ;; We've already tried this number, in the previous loop iteration, + ;; and failed. + (signal 'error `("Corrupt internal nnmaildir data" ,path-open))) + (setq path-link (concat numdir (number-to-string number-link))) + (nnmaildir--condcase err + (progn + (add-name-to-file path-open path-link) + (throw 'return number-link)) + (cond + ((nnmaildir--emlink-p err) + (setq make-new-file t + number-open number-link)) + ((nnmaildir--eexist-p err) + (let ((attr (file-attributes path-link))) + (unless (equal (nth 10 attr) ino-open) + (setq number-open number-link + number-link 0)))) + (t (signal (car err) (cdr err))))))))) + (defun nnmaildir--update-nov (server group article) (let ((nnheader-file-coding-system 'binary) (srv-dir (nnmaildir--srv-dir server)) + (storage-version 1) ;; [version article-number msgid [...nov...]] dir gname pgname msgdir prefix suffix file attr mtime novdir novfile - nov msgid nov-beg nov-mid nov-end field pos extra val old-extra - new-extra deactivate-mark) + nov msgid nov-beg nov-mid nov-end field val old-extra num numdir + deactivate-mark) (catch 'return - (setq suffix (nnmaildir--art-suffix article)) - (if (stringp suffix) nil - (setf (nnmaildir--art-nov article) nil) - (throw 'return nil)) (setq gname (nnmaildir--grp-name group) pgname (nnmaildir--pgname server gname) dir (nnmaildir--srvgrp-dir srv-dir gname) msgdir (if (nnmaildir--param pgname 'read-only) (nnmaildir--new dir) (nnmaildir--cur dir)) prefix (nnmaildir--art-prefix article) + suffix (nnmaildir--art-suffix article) file (concat msgdir prefix suffix) attr (file-attributes file)) - (if attr nil - (setf (nnmaildir--art-suffix article) 'expire) - (setf (nnmaildir--art-nov article) nil) + (unless attr + (nnmaildir--expired-article group article) (throw 'return nil)) (setq mtime (nth 5 attr) attr (nth 7 attr) nov (nnmaildir--art-nov article) - novdir (nnmaildir--nov-dir (nnmaildir--nndir dir)) + dir (nnmaildir--nndir dir) + novdir (nnmaildir--nov-dir dir) novfile (concat novdir prefix)) - (or (equal nnmaildir--extra nnmail-extra-headers) - (setq nnmaildir--extra (copy-sequence nnmail-extra-headers))) + (unless (equal nnmaildir--extra nnmail-extra-headers) + (setq nnmaildir--extra (copy-sequence nnmail-extra-headers))) (nnmaildir--with-nov-buffer - (when (file-exists-p novfile) ;; If not, force reparsing the message. - (if nov nil ;; It's already in memory. - ;; Else read the data from the NOV file. - (erase-buffer) - (nnheader-insert-file-contents novfile) - (setq nov (read (current-buffer))) - (setf (nnmaildir--art-msgid article) (car nov)) - (setq nov (cadr nov))) - ;; If the NOV's modtime matches the file's current modtime, and it - ;; has the right structure (i.e., it wasn't produced by a too-much - ;; older version of nnmaildir), then we may use this NOV data - ;; rather than parsing the message file, unless - ;; nnmail-extra-headers has been augmented since this data was last - ;; parsed. - (when (and (equal mtime (nnmaildir--nov-get-mtime nov)) - (= (length nov) nnmaildir--novlen) - (stringp (nnmaildir--nov-get-beg nov)) - (stringp (nnmaildir--nov-get-mid nov)) - (stringp (nnmaildir--nov-get-end nov)) - (listp (nnmaildir--nov-get-mtime nov)) - (listp (nnmaildir--nov-get-extra nov))) - ;; this NOV data is potentially up-to-date; now check extra headers - (setq old-extra (nnmaildir--nov-get-extra nov)) - (when (equal nnmaildir--extra old-extra) ;; common case - (nnmaildir--nov-set-extra nov nnmaildir--extra) ;; save memory + ;; First we'll check for already-parsed NOV data. + (cond ((not (file-exists-p novfile)) + ;; The NOV file doesn't exist; we have to parse the message. + (setq nov nil)) + ((not nov) + ;; The file exists, but the data isn't in memory; read the file. + (erase-buffer) + (nnheader-insert-file-contents novfile) + (setq nov (read (current-buffer))) + (if (not (and (vectorp nov) + (/= 0 (length nov)) + (equal storage-version (aref nov 0)))) + ;; This NOV data seems to be in the wrong format. + (setq nov nil) + (unless (nnmaildir--art-num article) + (setf (nnmaildir--art-num article) (aref nov 1))) + (unless (nnmaildir--art-msgid article) + (setf (nnmaildir--art-msgid article) (aref nov 2))) + (setq nov (aref nov 3))))) + ;; Now check whether the already-parsed data (if we have any) is + ;; usable: if the message has been edited or if nnmail-extra-headers + ;; has been augmented since this data was parsed from the message, + ;; then we have to reparse. Otherwise it's up-to-date. + (when (and nov (equal mtime (nnmaildir--nov-get-mtime nov))) + ;; The timestamp matches. Now check nnmail-extra-headers. + (setq old-extra (nnmaildir--nov-get-extra nov)) + (when (equal nnmaildir--extra old-extra) ;; common case + ;; Save memory; use a single copy of the list value. + (nnmaildir--nov-set-extra nov nnmaildir--extra) + (throw 'return nov)) + ;; They're not equal, but maybe the new is a subset of the old. + (if (null nnmaildir--extra) + ;; The empty set is a subset of every set. (throw 'return nov)) - ;; They're not equal, but maybe the new is a subset of the old... - (if (null nnmaildir--extra) (throw 'return nov)) - (setq new-extra nnmaildir--extra) - (while new-extra - (if (memq (car new-extra) old-extra) - (progn - (setq new-extra (cdr new-extra)) - (if new-extra nil (throw 'return nov))) - (setq new-extra nil))))) ;;found one not in old-extra;quit loop + (if (not (memq nil (mapcar (lambda (e) (memq e old-extra)) + nnmaildir--extra))) + (throw 'return nov))) ;; Parse the NOV data out of the message. (erase-buffer) (nnheader-insert-file-contents file) @@ -300,68 +506,47 @@ by nnmaildir-request-article.") (setq nov-mid 0)) (goto-char (point-min)) (delete-char 1) - (nnheader-fold-continuation-lines) - (setq nov (nnheader-parse-head 'naked) + (setq nov (nnheader-parse-naked-head) field (or (mail-header-lines nov) 0))) - (if (or (zerop field) (nnmaildir--param pgname 'distrust-Lines:)) nil + (unless (or (zerop field) (nnmaildir--param pgname 'distrust-Lines:)) (setq nov-mid field)) (setq nov-mid (number-to-string nov-mid) - nov-mid (concat (number-to-string attr) "\t" nov-mid) - field (or (mail-header-references nov) "") - pos 0) + nov-mid (concat (number-to-string attr) "\t" nov-mid)) (save-match-data - (while (string-match "\t" field pos) - (aset field (match-beginning 0) ? ) - (setq pos (match-end 0))) + (setq field (or (mail-header-references nov) "")) + (nnmaildir--tab-to-space field) (setq nov-mid (concat field "\t" nov-mid) - extra (mail-header-extra nov) - nov-end "") - (while extra - (setq field (car extra) extra (cdr extra) - val (cdr field) field (symbol-name (car field)) - pos 0) - (while (string-match "\t" field pos) - (aset field (match-beginning 0) ? ) - (setq pos (match-end 0))) - (setq pos 0) - (while (string-match "\t" val pos) - (aset val (match-beginning 0) ? ) - (setq pos (match-end 0))) - (setq nov-end (concat nov-end "\t" field ": " val))) - (setq nov-end (if (zerop (length nov-end)) "" (substring nov-end 1)) - field (or (mail-header-subject nov) "") - pos 0) - (while (string-match "\t" field pos) - (aset field (match-beginning 0) ? ) - (setq pos (match-end 0))) - (setq nov-beg field - field (or (mail-header-from nov) "") - pos 0) - (while (string-match "\t" field pos) - (aset field (match-beginning 0) ? ) - (setq pos (match-end 0))) - (setq nov-beg (concat nov-beg "\t" field) - field (or (mail-header-date nov) "") - pos 0) - (while (string-match "\t" field pos) - (aset field (match-beginning 0) ? ) - (setq pos (match-end 0))) - (setq nov-beg (concat nov-beg "\t" field) - field (mail-header-id nov) - pos 0) - (while (string-match "\t" field pos) - (aset field (match-beginning 0) ? ) - (setq pos (match-end 0))) - (setq msgid field)) + nov-beg (mapconcat + (lambda (f) (nnmaildir--tab-to-space (or f ""))) + (list (mail-header-subject nov) + (mail-header-from nov) + (mail-header-date nov)) "\t") + nov-end (mapconcat + (lambda (extra) + (setq field (symbol-name (car extra)) + val (cdr extra)) + (nnmaildir--tab-to-space field) + (nnmaildir--tab-to-space val) + (concat field ": " val)) + (mail-header-extra nov) "\t"))) + (setq msgid (mail-header-id nov)) (if (or (null msgid) (nnheader-fake-message-id-p msgid)) (setq msgid (concat "<" prefix "@nnmaildir>"))) + (nnmaildir--tab-to-space msgid) + ;; The data is parsed; create an nnmaildir NOV structure. (setq nov (nnmaildir--nov-new nov-beg nov-mid nov-end mtime - nnmaildir--extra)) + nnmaildir--extra) + num (nnmaildir--art-num article)) + (unless num + (setq num (nnmaildir--new-number dir)) + (setf (nnmaildir--art-num article) num)) + ;; Store this new NOV data in a file (erase-buffer) - (prin1 (list msgid nov) (current-buffer)) + (prin1 (vector storage-version num msgid nov) (current-buffer)) (setq file (concat novfile ":")) (nnmaildir--unlink file) - (write-region (point-min) (point-max) file nil 'no-message)) + (gmm-write-region (point-min) (point-max) file nil 'no-message nil + 'excl)) (rename-file file novfile 'replace) (setf (nnmaildir--art-msgid article) msgid) nov))) @@ -370,7 +555,7 @@ by nnmaildir-request-article.") (let ((cache (nnmaildir--grp-cache group)) (index (nnmaildir--grp-index group)) goner) - (if (nnmaildir--art-nov article) nil + (unless (nnmaildir--art-nov article) (setq goner (aref cache index)) (if goner (setf (nnmaildir--art-nov goner) nil)) (aset cache index article) @@ -379,20 +564,35 @@ by nnmaildir-request-article.") (defun nnmaildir--grp-add-art (server group article) (let ((nov (nnmaildir--update-nov server group article)) - old-lists new-lists) + count num min nlist nlist-cdr insert-nlist) (when nov - (setq old-lists (nnmaildir--grp-lists group) - new-lists (copy-nnmaildir--lists old-lists)) - (setf (nnmaildir--lists-nlist new-lists) - (cons article (nnmaildir--lists-nlist new-lists))) + (setq count (1+ (nnmaildir--grp-count group)) + num (nnmaildir--art-num article) + min (if (= count 1) num + (min num (nnmaildir--grp-min group))) + nlist (nnmaildir--grp-nlist group)) + (if (or (null nlist) (> num (caar nlist))) + (setq nlist (cons (cons num article) nlist)) + (setq insert-nlist t + nlist-cdr (cdr nlist)) + (while (and nlist-cdr (< num (caar nlist-cdr))) + (setq nlist nlist-cdr + nlist-cdr (cdr nlist)))) (let ((inhibit-quit t)) - (setf (nnmaildir--grp-lists group) new-lists) - (set (intern (nnmaildir--art-prefix article) - (nnmaildir--lists-flist new-lists)) - article) - (set (intern (nnmaildir--art-msgid article) - (nnmaildir--lists-mlist new-lists)) - article)) + (setf (nnmaildir--grp-count group) count) + (setf (nnmaildir--grp-min group) min) + (if insert-nlist + (setcdr nlist (cons (cons num article) nlist-cdr)) + (setf (nnmaildir--grp-nlist group) nlist)) + (set (intern (nnmaildir--art-prefix article) + (nnmaildir--grp-flist group)) + article) + (set (intern (nnmaildir--art-msgid article) + (nnmaildir--grp-mlist group)) + article) + (set (intern (nnmaildir--grp-name group) + (nnmaildir--srv-groups server)) + group)) (nnmaildir--cache-nov group article nov) t))) @@ -400,84 +600,77 @@ by nnmaildir-request-article.") (or (nnmaildir--param pgname 'directory-files) (nnmaildir--srv-ls server))) -(defun nnmaildir--article-count (group) - (let ((ct 0) - (min 1)) - (setq group (nnmaildir--grp-lists group) - group (nnmaildir--lists-nlist group)) - (while group - (if (stringp (nnmaildir--art-suffix (car group))) - (setq ct (1+ ct) - min (nnmaildir--art-num (car group)))) - (setq group (cdr group))) - (cons ct min))) - (defun nnmaildir-article-number-to-file-name (number group-name server-address-string) (let ((group (nnmaildir--prepare server-address-string group-name)) - list article suffix dir filename pgname) + article dir pgname) (catch 'return - (if (null group) - ;; The given group or server does not exist. - (throw 'return nil)) - (setq list (nnmaildir--grp-lists group) - list (nnmaildir--lists-nlist list) - article (nnmaildir--nlist-art list number)) - (if (null article) - ;; The given article number does not exist in this group. - (throw 'return nil)) - (setq suffix (nnmaildir--art-suffix article)) - (if (not (stringp suffix)) - ;; The article has expired. - (throw 'return nil)) - (setq dir (nnmaildir--srv-dir nnmaildir--cur-server) + (unless group + ;; The given group or server does not exist. + (throw 'return nil)) + (setq article (nnmaildir--nlist-art group number)) + (unless article + ;; The given article number does not exist in this group. + (throw 'return nil)) + (setq pgname (nnmaildir--pgname nnmaildir--cur-server group-name) + dir (nnmaildir--srv-dir nnmaildir--cur-server) dir (nnmaildir--srvgrp-dir dir group-name) - pgname (nnmaildir--pgname nnmaildir--cur-server group) - group (if (nnmaildir--param pgname 'read-only) - (nnmaildir--new dir) (nnmaildir--cur dir)) - filename (concat group (nnmaildir--art-prefix article) suffix)) - (if (file-exists-p filename) - filename - ;; The article disappeared out from under us. - (setf (nnmaildir--art-suffix article) 'expire) - (setf (nnmaildir--art-nov article) nil) - nil)))) + dir (if (nnmaildir--param pgname 'read-only) + (nnmaildir--new dir) (nnmaildir--cur dir))) + (concat dir (nnmaildir--art-prefix article) + (nnmaildir--art-suffix article))))) (defun nnmaildir-article-number-to-base-name (number group-name server-address-string) - (let ((group (nnmaildir--prepare server-address-string group-name)) - list article suffix dir filename) - (catch 'return - (if (null group) - ;; The given group or server does not exist. - (throw 'return nil)) - (setq list (nnmaildir--grp-lists group) - list (nnmaildir--lists-nlist list) - article (nnmaildir--nlist-art list number)) - (if (null article) - ;; The given article number does not exist in this group. - (throw 'return nil)) - (setq suffix (nnmaildir--art-suffix article)) - (if (not (stringp suffix)) - ;; The article has expired. - (throw 'return nil)) - (cons (nnmaildir--art-prefix article) suffix)))) + (let ((x (nnmaildir--prepare server-address-string group-name))) + (when x + (setq x (nnmaildir--nlist-art x number)) + (and x (cons (nnmaildir--art-prefix x) + (nnmaildir--art-suffix x)))))) (defun nnmaildir-base-name-to-article-number (base-name group-name server-address-string) - (let ((group (nnmaildir--prepare server-address-string group-name)) - list article suffix dir filename) - (catch 'return - (if (null group) - ;; The given group or server does not exist. - (throw 'return nil)) - (setq list (nnmaildir--grp-lists group) - list (nnmaildir--lists-flist list) - article (nnmaildir--flist-art list base-name)) - (if (null article) - ;; The given article number does not exist in this group. - (throw 'return nil)) - (nnmaildir--art-num article)))) + (let ((x (nnmaildir--prepare server-address-string group-name))) + (when x + (setq x (nnmaildir--grp-flist x) + x (nnmaildir--flist-art x base-name)) + (and x (nnmaildir--art-num x))))) + +(defun nnmaildir--nlist-iterate (nlist ranges func) + (let (entry high low nlist2) + (if (eq ranges 'all) + (setq ranges `((1 . ,(caar nlist))))) + (while ranges + (setq entry (car ranges) ranges (cdr ranges)) + (while (and ranges (eq entry (car ranges))) + (setq ranges (cdr ranges))) ;; skip duplicates + (if (numberp entry) + (setq low entry + high entry) + (setq low (car entry) + high (cdr entry))) + (setq nlist2 nlist) ;; Don't assume any sorting of ranges + (catch 'iterate-loop + (while nlist2 + (if (<= (caar nlist2) high) (throw 'iterate-loop nil)) + (setq nlist2 (cdr nlist2)))) + (catch 'iterate-loop + (while nlist2 + (setq entry (car nlist2) nlist2 (cdr nlist2)) + (if (< (car entry) low) (throw 'iterate-loop nil)) + (funcall func (cdr entry))))))) + +(defun nnmaildir--up2-1 (n) + (if (zerop n) 1 (1- (lsh 1 (1+ (logb n)))))) + +(defun nnmaildir--system-name () + (gnus-replace-in-string + (gnus-replace-in-string + (gnus-replace-in-string + (system-name) + "\\\\" "\\134" 'literal) + "/" "\\057" 'literal) + ":" "\\072" 'literal)) (defun nnmaildir-request-type (group &optional article) 'mail) @@ -505,10 +698,10 @@ by nnmaildir-request-article.") (setq nnmaildir--cur-server server) (throw 'return t)) (setq server (make-nnmaildir--srv :address x)) - (let ((inhibit-quit t)) - (set (intern x nnmaildir--servers) server))) + (let ((inhibit-quit t)) + (set (intern x nnmaildir--servers) server))) (setq dir (assq 'directory defs)) - (if dir nil + (unless dir (setf (nnmaildir--srv-error server) "You must set \"directory\" in the select method") (throw 'return nil)) @@ -516,36 +709,41 @@ by nnmaildir-request-article.") dir (eval dir) dir (expand-file-name dir) dir (file-name-as-directory dir)) - (if (file-exists-p dir) nil + (unless (file-exists-p dir) (setf (nnmaildir--srv-error server) (concat "No such directory: " dir)) (throw 'return nil)) (setf (nnmaildir--srv-dir server) dir) (setq x (assq 'directory-files defs)) (if (null x) - (setq x (symbol-function (if nnheader-directory-files-is-safe - 'directory-files - 'nnheader-directory-files-safe))) + (setq x (if nnheader-directory-files-is-safe 'directory-files + 'nnheader-directory-files-safe)) (setq x (cadr x)) - (if (functionp x) nil + (unless (functionp x) (setf (nnmaildir--srv-error server) (concat "Not a function: " (prin1-to-string x))) (throw 'return nil))) (setf (nnmaildir--srv-ls server) x) - (setq x (funcall x dir nil "\\`[^.]" 'nosort) - x (length x) - size 1) - (while (<= size x) (setq size (* 2 size))) - (if (/= size 1) (setq size (1- size))) + (setq size (length (funcall x dir nil "\\`[^.]" 'nosort)) + size (nnmaildir--up2-1 size)) (and (setq x (assq 'get-new-mail defs)) (setq x (cdr x)) (car x) (setf (nnmaildir--srv-gnm server) t) (require 'nnmail)) - (setq x (assq 'create-directory defs)) - (when x - (setq x (cadr x) - x (eval x)) - (setf (nnmaildir--srv-create-dir server) x)) + (setq x (assq 'target-prefix defs)) + (if x + (progn + (setq x (cadr x) + x (eval x)) + (setf (nnmaildir--srv-target-prefix server) x)) + (setq x (assq 'create-directory defs)) + (if x + (progn + (setq x (cadr x) + x (eval x) + x (file-name-as-directory x)) + (setf (nnmaildir--srv-target-prefix server) x)) + (setf (nnmaildir--srv-target-prefix server) ""))) (setf (nnmaildir--srv-groups server) (make-vector size 0)) (setq nnmaildir--cur-server server) t))) @@ -553,17 +751,13 @@ by nnmaildir-request-article.") (defun nnmaildir--parse-filename (file) (let ((prefix (car file)) timestamp len) - (if (string-match - "\\`\\([0-9]+\\)\\.\\([0-9]+\\)\\(_\\([0-9]+\\)\\)?\\(\\..*\\)\\'" - prefix) + (if (string-match "\\`\\([0-9]+\\)\\(\\..*\\)\\'" prefix) (progn (setq timestamp (concat "0000" (match-string 1 prefix)) len (- (length timestamp) 4)) (vector (string-to-number (substring timestamp 0 len)) (string-to-number (substring timestamp len)) - (string-to-number (match-string 2 prefix)) - (string-to-number (or (match-string 4 prefix) "-1")) - (match-string 5 prefix) + (match-string 2 prefix) file)) file))) @@ -576,20 +770,16 @@ by nnmaildir-request-article.") (if (> (aref a 0) (aref b 0)) (throw 'return nil)) (if (< (aref a 1) (aref b 1)) (throw 'return t)) (if (> (aref a 1) (aref b 1)) (throw 'return nil)) - (if (< (aref a 2) (aref b 2)) (throw 'return t)) - (if (> (aref a 2) (aref b 2)) (throw 'return nil)) - (if (< (aref a 3) (aref b 3)) (throw 'return t)) - (if (> (aref a 3) (aref b 3)) (throw 'return nil)) - (string-lessp (aref a 4) (aref b 4)))) + (string-lessp (aref a 2) (aref b 2)))) (defun nnmaildir--scan (gname scan-msgs groups method srv-dir srv-ls) (catch 'return (let ((36h-ago (- (car (current-time)) 2)) absdir nndir tdir ndir cdir nattr cattr isnew pgname read-only ls - files file num dir flist group x) + files num dir flist group x) (setq absdir (nnmaildir--srvgrp-dir srv-dir gname) nndir (nnmaildir--nndir absdir)) - (if (file-exists-p absdir) nil + (unless (file-exists-p absdir) (setf (nnmaildir--srv-error nnmaildir--cur-server) (concat "No such directory: " absdir)) (throw 'return nil)) @@ -598,7 +788,7 @@ by nnmaildir-request-article.") cdir (nnmaildir--cur absdir) nattr (file-attributes ndir) cattr (file-attributes cdir)) - (if (and (file-exists-p tdir) nattr cattr) nil + (unless (and (file-exists-p tdir) nattr cattr) (setf (nnmaildir--srv-error nnmaildir--cur-server) (concat "Not a maildir: " absdir)) (throw 'return nil)) @@ -607,25 +797,21 @@ by nnmaildir-request-article.") (if group (setq isnew nil) (setq isnew t - group (make-nnmaildir--grp :name gname :index 0 - :lists (make-nnmaildir--lists))) + group (make-nnmaildir--grp :name gname :index 0)) (nnmaildir--mkdir nndir) (nnmaildir--mkdir (nnmaildir--nov-dir nndir)) - (nnmaildir--mkdir (nnmaildir--marks-dir nndir)) - (write-region "" nil (concat nndir "markfile") nil 'no-message)) + (nnmaildir--mkdir (nnmaildir--marks-dir nndir))) (setq read-only (nnmaildir--param pgname 'read-only) ls (or (nnmaildir--param pgname 'directory-files) srv-ls)) - (if read-only nil + (unless read-only (setq x (nth 11 (file-attributes tdir))) - (if (and (= x (nth 11 nattr)) (= x (nth 11 cattr))) nil + (unless (and (equal x (nth 11 nattr)) (equal x (nth 11 cattr))) (setf (nnmaildir--srv-error nnmaildir--cur-server) (concat "Maildir spans filesystems: " absdir)) (throw 'return nil)) - (setq files (funcall ls tdir 'full "\\`[^.]" 'nosort)) - (while files - (setq file (car files) files (cdr files) - x (file-attributes file)) - (if (or (< 1 (cadr x)) (> 36h-ago (car (nth 4 x)))) + (dolist (file (funcall ls tdir 'full "\\`[^.]" 'nosort)) + (setq x (file-attributes file)) + (if (or (> (cadr x) 1) (< (car (nth 4 x)) 36h-ago)) (delete-file file)))) (or scan-msgs isnew @@ -635,65 +821,68 @@ by nnmaildir-request-article.") (setq nattr nil)) (if read-only (setq dir (and (or isnew nattr) ndir)) (when (or isnew nattr) - (setq files (funcall ls ndir nil "\\`[^.]" 'nosort)) - (while files - (setq file (car files) files (cdr files)) - (rename-file (concat ndir file) (concat cdir file ":2,"))) + (dolist (file (funcall ls ndir nil "\\`[^.]" 'nosort)) + (setq x (concat ndir file)) + (and (time-less-p (nth 5 (file-attributes x)) (current-time)) + (rename-file x (concat cdir (nnmaildir--ensure-suffix file))))) (setf (nnmaildir--grp-new group) nattr)) (setq cattr (nth 5 (file-attributes cdir))) (if (equal cattr (nnmaildir--grp-cur group)) (setq cattr nil)) (setq dir (and (or isnew cattr) cdir))) - (if dir nil (throw 'return t)) - (setq files (funcall ls dir nil "\\`[^.]" 'nosort)) + (unless dir (throw 'return t)) + (setq files (funcall ls dir nil "\\`[^.]" 'nosort) + files (save-match-data + (mapcar + (lambda (f) + (string-match "\\`\\([^:]*\\)\\(\\(:.*\\)?\\)\\'" f) + (cons (match-string 1 f) (match-string 2 f))) + files))) (when isnew - (setq x (length files) - num 1) - (while (<= num x) (setq num (* 2 num))) - (if (/= num 1) (setq num (1- num))) - (setq x (nnmaildir--grp-lists group)) - (setf (nnmaildir--lists-flist x) (make-vector num 0)) - (setf (nnmaildir--lists-mlist x) (make-vector num 0)) + (setq num (nnmaildir--up2-1 (length files))) + (setf (nnmaildir--grp-flist group) (make-vector num 0)) + (setf (nnmaildir--grp-mlist group) (make-vector num 0)) (setf (nnmaildir--grp-mmth group) (make-vector 1 0)) (setq num (nnmaildir--param pgname 'nov-cache-size)) (if (numberp num) (if (< num 1) (setq num 1)) - (setq x files - num 16 + (setq num 16 cdir (nnmaildir--marks-dir nndir) ndir (nnmaildir--subdir cdir "tick") cdir (nnmaildir--subdir cdir "read")) - (while x - (setq file (car x) x (cdr x)) - (string-match "\\`\\([^:]*\\)\\(\\(:.*\\)?\\)\\'" file) - (setq file (match-string 1 file)) - (if (or (not (file-exists-p (concat cdir file))) - (file-exists-p (concat ndir file))) - (setq num (1+ num))))) + (dolist (prefix-suffix files) + (let ((prefix (car prefix-suffix)) + (suffix (cdr prefix-suffix))) + ;; increase num for each unread or ticked article + (when (or + ;; first look for marks in suffix, if it's valid... + (when (and (stringp suffix) + (gnus-string-prefix-p ":2," suffix)) + (or + (not (gnus-string-match-p + (string (nnmaildir--mark-to-flag 'read)) suffix)) + (gnus-string-match-p + (string (nnmaildir--mark-to-flag 'tick)) suffix))) + ;; then look in marks directories + (not (file-exists-p (concat cdir prefix))) + (file-exists-p (concat ndir prefix))) + (incf num))))) (setf (nnmaildir--grp-cache group) (make-vector num nil)) (let ((inhibit-quit t)) (set (intern gname groups) group)) (or scan-msgs (throw 'return t))) - (setq flist (nnmaildir--grp-lists group) - num (nnmaildir--lists-nlist flist) - flist (nnmaildir--lists-flist flist) - num (nnmaildir--nlist-last-num num) - x files - files nil) - (while x - (setq file (car x) x (cdr x)) - (string-match "\\`\\([^:]*\\)\\(\\(:.*\\)?\\)\\'" file) - (setq file (cons (match-string 1 file) (match-string 2 file))) - (if (nnmaildir--flist-art flist (car file)) nil - (setq files (cons file files)))) - (setq files (mapcar 'nnmaildir--parse-filename files) + (setq flist (nnmaildir--grp-flist group) + files (mapcar + (lambda (file) + (and (null (nnmaildir--flist-art flist (car file))) + file)) + files) + files (delq nil files) + files (mapcar 'nnmaildir--parse-filename files) files (sort files 'nnmaildir--sort-files)) - (while files - (setq file (car files) files (cdr files) - file (if (consp file) file (aref file 5)) - x (make-nnmaildir--art :prefix (car file) :suffix(cdr file) - :num (1+ num))) - (if (nnmaildir--grp-add-art nnmaildir--cur-server group x) - (setq num (1+ num)))) + (dolist (file files) + (setq file (if (consp file) file (aref file 3)) + x (make-nnmaildir--art :prefix (car file) :suffix (cdr file))) + (nnmaildir--grp-add-art nnmaildir--cur-server group x)) (if read-only (setf (nnmaildir--grp-new group) nattr) (setf (nnmaildir--grp-cur group) cattr))) t)) @@ -702,15 +891,17 @@ by nnmaildir-request-article.") (let ((coding-system-for-write nnheader-file-coding-system) (buffer-file-coding-system nil) (file-coding-system-alist nil) - (nnmaildir-new-mail t) + (nnmaildir-get-new-mail t) (nnmaildir-group-alist nil) (nnmaildir-active-file nil) - x srv-ls srv-dir method groups group dirs grp-dir seen deactivate-mark) + x srv-ls srv-dir method groups target-prefix group dirs grp-dir seen + deactivate-mark) (nnmaildir--prepare server nil) (setq srv-ls (nnmaildir--srv-ls nnmaildir--cur-server) srv-dir (nnmaildir--srv-dir nnmaildir--cur-server) method (nnmaildir--srv-method nnmaildir--cur-server) - groups (nnmaildir--srv-groups nnmaildir--cur-server)) + groups (nnmaildir--srv-groups nnmaildir--cur-server) + target-prefix (nnmaildir--srv-target-prefix nnmaildir--cur-server)) (nnmaildir--with-work-buffer (save-match-data (if (stringp scan-group) @@ -718,58 +909,63 @@ by nnmaildir-request-article.") (if (nnmaildir--srv-gnm nnmaildir--cur-server) (nnmail-get-new-mail 'nnmaildir nil nil scan-group)) (unintern scan-group groups)) - (setq x (nth 5 (file-attributes srv-dir))) + (setq x (nth 5 (file-attributes srv-dir)) + scan-group (null scan-group)) (if (equal x (nnmaildir--srv-mtime nnmaildir--cur-server)) - (if scan-group nil - (mapatoms (lambda (sym) - (nnmaildir--scan (symbol-name sym) t groups - method srv-dir srv-ls)) - groups)) + (if scan-group + (mapatoms (lambda (sym) + (nnmaildir--scan (symbol-name sym) t groups + method srv-dir srv-ls)) + groups)) (setq dirs (funcall srv-ls srv-dir nil "\\`[^.]" 'nosort) - x (length dirs) - seen 1) - (while (<= seen x) (setq seen (* 2 seen))) - (if (/= seen 1) (setq seen (1- seen))) - (setq seen (make-vector seen 0) - scan-group (null scan-group)) - (while dirs - (setq grp-dir (car dirs) dirs (cdr dirs)) + dirs (if (zerop (length target-prefix)) + dirs + (gnus-remove-if + (lambda (dir) + (and (>= (length dir) (length target-prefix)) + (string= (substring dir 0 + (length target-prefix)) + target-prefix))) + dirs)) + seen (nnmaildir--up2-1 (length dirs)) + seen (make-vector seen 0)) + (dolist (grp-dir dirs) (if (nnmaildir--scan grp-dir scan-group groups method srv-dir srv-ls) (intern grp-dir seen))) (setq x nil) (mapatoms (lambda (group) (setq group (symbol-name group)) - (if (intern-soft group seen) nil + (unless (intern-soft group seen) (setq x (cons group x)))) groups) - (while x - (unintern (car x) groups) - (setq x (cdr x))) + (dolist (grp x) + (unintern grp groups)) (setf (nnmaildir--srv-mtime nnmaildir--cur-server) (nth 5 (file-attributes srv-dir)))) - (if (nnmaildir--srv-gnm nnmaildir--cur-server) - (nnmail-get-new-mail 'nnmaildir nil nil)))))) + (and scan-group + (nnmaildir--srv-gnm nnmaildir--cur-server) + (nnmail-get-new-mail 'nnmaildir nil nil)))))) t) (defun nnmaildir-request-list (&optional server) (nnmaildir-request-scan 'find-new-groups server) - (let (pgname ro ct-min deactivate-mark) + (let (pgname ro deactivate-mark) (nnmaildir--prepare server nil) (nnmaildir--with-nntp-buffer (erase-buffer) (mapatoms (lambda (group) - (setq ro (nnmaildir--param - (nnmaildir--pgname nnmaildir--cur-server group) - 'read-only) - ct-min (nnmaildir--article-count (symbol-value group))) - (insert (nnmaildir--grp-name group) " ") - (princ (nnmaildir--nlist-last-num - (nnmaildir--lists-nlist - (nnmaildir--grp-lists group))) - nntp-server-buffer) + (setq pgname (symbol-name group) + pgname (nnmaildir--pgname nnmaildir--cur-server pgname) + group (symbol-value group) + ro (nnmaildir--param pgname 'read-only)) + (insert (gnus-replace-in-string + (nnmaildir--grp-name group) " " "\\ " t) + " ") + (princ (nnmaildir--group-maxnum nnmaildir--cur-server group) + nntp-server-buffer) (insert " ") - (princ (cdr ct-min) nntp-server-buffer) + (princ (nnmaildir--grp-min group) nntp-server-buffer) (insert " " (if ro "n" "y") "\n")) (nnmaildir--srv-groups nnmaildir--cur-server)))) t) @@ -778,126 +974,159 @@ by nnmaildir-request-article.") (nnmaildir-request-list server)) (defun nnmaildir-retrieve-groups (groups &optional server) - (let (gname group ct-min deactivate-mark) + (let (group deactivate-mark) (nnmaildir--prepare server nil) (nnmaildir--with-nntp-buffer (erase-buffer) - (while groups - (setq gname (car groups) groups (cdr groups)) - (nnmaildir-request-scan gname server) + (dolist (gname groups) (setq group (nnmaildir--prepare nil gname)) (if (null group) (insert "411 no such news group\n") - (setq ct-min (nnmaildir--article-count group)) (insert "211 ") - (princ (car ct-min) nntp-server-buffer) + (princ (nnmaildir--grp-count group) nntp-server-buffer) (insert " ") - (princ (cdr ct-min) nntp-server-buffer) + (princ (nnmaildir--grp-min group) nntp-server-buffer) (insert " ") - (princ (nnmaildir--nlist-last-num - (nnmaildir--lists-nlist - (nnmaildir--grp-lists group))) + (princ (nnmaildir--group-maxnum nnmaildir--cur-server group) nntp-server-buffer) - (insert " " gname "\n"))))) + (insert " " + (gnus-replace-in-string gname " " "\\ " t) + "\n"))))) 'group) (defun nnmaildir-request-update-info (gname info &optional server) - (nnmaildir-request-scan gname server) - (let ((group (nnmaildir--prepare server gname)) - pgname nlist flist last always-marks never-marks old-marks dotfile num - dir markdirs marks mark ranges articles article read end new-marks ls - old-mmth new-mmth mtime mark-sym deactivate-mark) + (let* ((group (nnmaildir--prepare server gname)) + (curdir (nnmaildir--cur + (nnmaildir--srvgrp-dir + (nnmaildir--srv-dir nnmaildir--cur-server) gname))) + (curdir-mtime (nth 5 (file-attributes curdir))) + pgname flist always-marks never-marks old-marks dotfile num dir + all-marks marks mark ranges markdir read end new-marks ls + old-mmth new-mmth mtime mark-sym existing missing deactivate-mark) (catch 'return - (if group nil + (unless group (setf (nnmaildir--srv-error nnmaildir--cur-server) (concat "No such group: " gname)) (throw 'return nil)) (setq gname (nnmaildir--grp-name group) pgname (nnmaildir--pgname nnmaildir--cur-server gname) - nlist (nnmaildir--grp-lists group) - flist (nnmaildir--lists-flist nlist) - nlist (nnmaildir--lists-nlist nlist)) - (if nlist nil + flist (nnmaildir--grp-flist group)) + (when (zerop (nnmaildir--grp-count group)) (gnus-info-set-read info nil) (gnus-info-set-marks info nil 'extend) (throw 'return info)) (setq old-marks (cons 'read (gnus-info-read info)) old-marks (cons old-marks (gnus-info-marks info)) - last (nnmaildir--nlist-last-num nlist) always-marks (nnmaildir--param pgname 'always-marks) never-marks (nnmaildir--param pgname 'never-marks) + existing (nnmaildir--grp-nlist group) + existing (mapcar 'car existing) + existing (nreverse existing) + existing (gnus-compress-sequence existing 'always-list) + missing (list (cons 1 (nnmaildir--group-maxnum + nnmaildir--cur-server group))) + missing (gnus-range-difference missing existing) dir (nnmaildir--srv-dir nnmaildir--cur-server) dir (nnmaildir--srvgrp-dir dir gname) dir (nnmaildir--nndir dir) dir (nnmaildir--marks-dir dir) ls (nnmaildir--group-ls nnmaildir--cur-server pgname) - markdirs (funcall ls dir nil "\\`[^.]" 'nosort) - num (length markdirs) - new-mmth 1) - (while (<= new-mmth num) (setq new-mmth (* 2 new-mmth))) - (if (/= new-mmth 1) (setq new-mmth (1- new-mmth))) - (setq new-mmth (make-vector new-mmth 0) + all-marks (gnus-delete-duplicates + ;; get mark names from mark dirs and from flag + ;; mappings + (append + (mapcar 'cdr nnmaildir-flag-mark-mapping) + (mapcar 'intern (funcall ls dir nil "\\`[^.]" 'nosort)))) + new-mmth (nnmaildir--up2-1 (length all-marks)) + new-mmth (make-vector new-mmth 0) old-mmth (nnmaildir--grp-mmth group)) - (while markdirs - (setq mark (car markdirs) markdirs (cdr markdirs) - articles (nnmaildir--subdir dir mark) - mark-sym (intern mark) + (dolist (mark all-marks) + (setq markdir (nnmaildir--subdir dir (symbol-name mark)) ranges nil) (catch 'got-ranges - (if (memq mark-sym never-marks) (throw 'got-ranges nil)) - (when (memq mark-sym always-marks) - (setq ranges (list (cons 1 last))) + (if (memq mark never-marks) (throw 'got-ranges nil)) + (when (memq mark always-marks) + (setq ranges existing) (throw 'got-ranges nil)) - (setq mtime (nth 5 (file-attributes articles))) - (set (intern mark new-mmth) mtime) - (when (equal mtime (symbol-value (intern-soft mark old-mmth))) - (setq ranges (assq mark-sym old-marks)) + ;; Find the mtime for this mark. If this mark can be expressed as + ;; a filename flag, get the later of the mtimes for markdir and + ;; curdir, otherwise only the markdir counts. + (setq mtime + (let ((markdir-mtime (nth 5 (file-attributes markdir)))) + (cond + ((null (nnmaildir--mark-to-flag mark)) + markdir-mtime) + ((null markdir-mtime) + curdir-mtime) + ((null curdir-mtime) + ;; this should never happen... + markdir-mtime) + ((time-less-p markdir-mtime curdir-mtime) + curdir-mtime) + (t + markdir-mtime)))) + (set (intern (symbol-name mark) new-mmth) mtime) + (when (equal mtime (symbol-value (intern-soft (symbol-name mark) old-mmth))) + (setq ranges (assq mark old-marks)) (if ranges (setq ranges (cdr ranges))) (throw 'got-ranges nil)) - (setq articles (funcall ls articles nil "\\`[^.]" 'nosort)) - (while articles - (setq article (car articles) articles (cdr articles) - article (nnmaildir--flist-art flist article)) - (if article - (setq num (nnmaildir--art-num article) - ranges (gnus-add-to-range ranges (list num)))))) - (if (eq mark-sym 'read) (setq read ranges) - (if ranges (setq marks (cons (cons mark-sym ranges) marks))))) - (gnus-info-set-read info read) + (let ((article-list nil)) + ;; Consider the article marked if it either has the flag in the + ;; filename, or is in the markdir. As you'd rarely remove a + ;; flag/mark, this should avoid losing information in the most + ;; common usage pattern. + (or + (let ((flag (nnmaildir--mark-to-flag mark))) + ;; If this mark has a corresponding maildir flag... + (when flag + (let ((regexp + (concat "\\`[^.].*:2,[A-Z]*" (string flag)))) + ;; ...then find all files with that flag. + (dolist (filename (funcall ls curdir nil regexp 'nosort)) + (let* ((prefix (car (split-string filename ":2,"))) + (article (nnmaildir--flist-art flist prefix))) + (when article + (push (nnmaildir--art-num article) article-list))))))) + ;; Also check Gnus-specific mark directory, if it exists. + (when (file-directory-p markdir) + (dolist (prefix (funcall ls markdir nil "\\`[^.]" 'nosort)) + (let ((article (nnmaildir--flist-art flist prefix))) + (when article + (push (nnmaildir--art-num article) article-list)))))) + (setq ranges (gnus-add-to-range ranges (sort article-list '<))))) + (if (eq mark 'read) (setq read ranges) + (if ranges (setq marks (cons (cons mark ranges) marks))))) + (gnus-info-set-read info (gnus-range-add read missing)) (gnus-info-set-marks info marks 'extend) (setf (nnmaildir--grp-mmth group) new-mmth) info))) -(defun nnmaildir-request-group (gname &optional server fast) - (nnmaildir-request-scan gname server) +(defun nnmaildir-request-group (gname &optional server fast info) (let ((group (nnmaildir--prepare server gname)) - ct-min deactivate-mark) - (nnmaildir--with-nntp-buffer - (erase-buffer) - (catch 'return - (if group nil - (insert "411 no such news group\n") - (setf (nnmaildir--srv-error nnmaildir--cur-server) - (concat "No such group: " gname)) - (throw 'return nil)) - (setf (nnmaildir--srv-curgrp nnmaildir--cur-server) group) - (if fast (throw 'return t)) - (setq ct-min (nnmaildir--article-count group)) + deactivate-mark) + (catch 'return + (unless group + ;; (insert "411 no such news group\n") + (setf (nnmaildir--srv-error nnmaildir--cur-server) + (concat "No such group: " gname)) + (throw 'return nil)) + (setf (nnmaildir--srv-curgrp nnmaildir--cur-server) group) + (if fast (throw 'return t)) + (nnmaildir--with-nntp-buffer + (erase-buffer) (insert "211 ") - (princ (car ct-min) nntp-server-buffer) + (princ (nnmaildir--grp-count group) nntp-server-buffer) (insert " ") - (princ (cdr ct-min) nntp-server-buffer) + (princ (nnmaildir--grp-min group) nntp-server-buffer) (insert " ") - (princ (nnmaildir--nlist-last-num - (nnmaildir--lists-nlist - (nnmaildir--grp-lists group))) + (princ (nnmaildir--group-maxnum nnmaildir--cur-server group) nntp-server-buffer) - (insert " " gname "\n") + (insert " " (gnus-replace-in-string gname " " "\\ " t) "\n") t)))) (defun nnmaildir-request-create-group (gname &optional server args) (nnmaildir--prepare server nil) (catch 'return - (let ((create-dir (nnmaildir--srv-create-dir nnmaildir--cur-server)) + (let ((target-prefix (nnmaildir--srv-target-prefix nnmaildir--cur-server)) srv-dir dir groups) (when (zerop (length gname)) (setf (nnmaildir--srv-error nnmaildir--cur-server) @@ -909,7 +1138,7 @@ by nnmaildir-request-article.") (throw 'return nil)) (when (save-match-data (string-match "[\0/\t]" gname)) (setf (nnmaildir--srv-error nnmaildir--cur-server) - (concat "Illegal characters (null, tab, or /) in group name: " + (concat "Invalid characters (null, tab, or /) in group name: " gname)) (throw 'return nil)) (setq groups (nnmaildir--srv-groups nnmaildir--cur-server)) @@ -918,18 +1147,19 @@ by nnmaildir-request-article.") (concat "Group already exists: " gname)) (throw 'return nil)) (setq srv-dir (nnmaildir--srv-dir nnmaildir--cur-server)) - (if (file-name-absolute-p create-dir) - (setq dir (expand-file-name create-dir)) + (if (file-name-absolute-p target-prefix) + (setq dir (expand-file-name target-prefix)) (setq dir srv-dir dir (file-truename dir) - dir (concat dir create-dir))) - (setq dir (nnmaildir--subdir (file-name-as-directory dir) gname)) + dir (concat dir target-prefix))) + (setq dir (nnmaildir--subdir dir gname)) (nnmaildir--mkdir dir) (nnmaildir--mkdir (nnmaildir--tmp dir)) (nnmaildir--mkdir (nnmaildir--new dir)) (nnmaildir--mkdir (nnmaildir--cur dir)) - (setq create-dir (file-name-as-directory create-dir)) - (make-symbolic-link (concat create-dir gname) (concat srv-dir gname)) + (unless (string= target-prefix "") + (make-symbolic-link (concat target-prefix gname) + (concat srv-dir gname))) (nnmaildir-request-scan 'find-new-groups)))) (defun nnmaildir-request-rename-group (gname new-name &optional server) @@ -939,7 +1169,7 @@ by nnmaildir-request-article.") (file-coding-system-alist nil) srv-dir x groups) (catch 'return - (if group nil + (unless group (setf (nnmaildir--srv-error nnmaildir--cur-server) (concat "No such group: " gname)) (throw 'return nil)) @@ -953,7 +1183,7 @@ by nnmaildir-request-article.") (throw 'return nil)) (when (save-match-data (string-match "[\0/\t]" new-name)) (setf (nnmaildir--srv-error nnmaildir--cur-server) - (concat "Illegal characters (null, tab, or /) in group name: " + (concat "Invalid characters (null, tab, or /) in group name: " new-name)) (throw 'return nil)) (if (string-equal gname new-name) (throw 'return t)) @@ -973,7 +1203,7 @@ by nnmaildir-request-article.") (setq x (nnmaildir--srv-groups nnmaildir--cur-server) groups (make-vector (length x) 0)) (mapatoms (lambda (sym) - (if (eq (symbol-value sym) group) nil + (unless (eq (symbol-value sym) group) (set (intern (symbol-name sym) groups) (symbol-value sym)))) x) @@ -985,212 +1215,154 @@ by nnmaildir-request-article.") (defun nnmaildir-request-delete-group (gname force &optional server) (let ((group (nnmaildir--prepare server gname)) - pgname grp-dir dir dirs files ls deactivate-mark) + pgname grp-dir target dir ls deactivate-mark) (catch 'return - (if group nil + (unless group (setf (nnmaildir--srv-error nnmaildir--cur-server) (concat "No such group: " gname)) (throw 'return nil)) + (setq gname (nnmaildir--grp-name group) + pgname (nnmaildir--pgname nnmaildir--cur-server gname) + grp-dir (nnmaildir--srv-dir nnmaildir--cur-server) + target (car (file-attributes (concat grp-dir gname))) + grp-dir (nnmaildir--srvgrp-dir grp-dir gname)) + (unless (or force (stringp target)) + (setf (nnmaildir--srv-error nnmaildir--cur-server) + (concat "Not a symlink: " gname)) + (throw 'return nil)) (if (eq group (nnmaildir--srv-curgrp nnmaildir--cur-server)) (setf (nnmaildir--srv-curgrp nnmaildir--cur-server) nil)) - (setq gname (nnmaildir--grp-name group) - pgname (nnmaildir--pgname nnmaildir--cur-server gname)) (unintern gname (nnmaildir--srv-groups nnmaildir--cur-server)) - (setq grp-dir (nnmaildir--srv-dir nnmaildir--cur-server) - grp-dir (nnmaildir--srvgrp-dir grp-dir gname)) - (if (not force) (setq grp-dir (directory-file-name grp-dir)) + (if (not force) + (progn + (setq grp-dir (directory-file-name grp-dir)) + (nnmaildir--unlink grp-dir)) + (setq ls (nnmaildir--group-ls nnmaildir--cur-server pgname)) (if (nnmaildir--param pgname 'read-only) (progn (delete-directory (nnmaildir--tmp grp-dir)) (nnmaildir--unlink (nnmaildir--new grp-dir)) (delete-directory (nnmaildir--cur grp-dir))) - (nnmaildir--with-work-buffer - (erase-buffer) - (setq ls (nnmaildir--group-ls nnmaildir--cur-server pgname) - files (funcall ls (nnmaildir--tmp grp-dir) 'full "\\`[^.]" - 'nosort)) - (while files - (delete-file (car files)) - (setq files (cdr files))) - (delete-directory (nnmaildir--tmp grp-dir)) - (setq files (funcall ls (nnmaildir--new grp-dir) 'full "\\`[^.]" - 'nosort)) - (while files - (delete-file (car files)) - (setq files (cdr files))) - (delete-directory (nnmaildir--new grp-dir)) - (setq files (funcall ls (nnmaildir--cur grp-dir) 'full "\\`[^.]" - 'nosort)) - (while files - (delete-file (car files)) - (setq files (cdr files))) - (delete-directory (nnmaildir--cur grp-dir)))) - (setq dir (nnmaildir--nndir grp-dir) - dirs (cons (nnmaildir--nov-dir dir) - (funcall ls (nnmaildir--marks-dir dir) 'full "\\`[^.]" - 'nosort))) - (while dirs - (setq dir (car dirs) dirs (cdr dirs) - files (funcall ls dir 'full "\\`[^.]" 'nosort)) - (while files - (delete-file (car files)) - (setq files (cdr files))) - (delete-directory dir)) + (nnmaildir--delete-dir-files (nnmaildir--tmp grp-dir) ls) + (nnmaildir--delete-dir-files (nnmaildir--new grp-dir) ls) + (nnmaildir--delete-dir-files (nnmaildir--cur grp-dir) ls)) + (setq dir (nnmaildir--nndir grp-dir)) + (dolist (subdir `(,(nnmaildir--nov-dir dir) ,(nnmaildir--num-dir dir) + ,@(funcall ls (nnmaildir--marks-dir dir) + 'full "\\`[^.]" 'nosort))) + (nnmaildir--delete-dir-files subdir ls)) (setq dir (nnmaildir--nndir grp-dir)) (nnmaildir--unlink (concat dir "markfile")) (nnmaildir--unlink (concat dir "markfile{new}")) (delete-directory (nnmaildir--marks-dir dir)) (delete-directory dir) - (setq grp-dir (directory-file-name grp-dir) - dir (car (file-attributes grp-dir))) - (if (eq (aref "/" 0) (aref dir 0)) nil - (setq dir (concat (file-truename - (nnmaildir--srv-dir nnmaildir--cur-server)) - dir))) - (delete-directory dir)) - (nnmaildir--unlink grp-dir) + (if (not (stringp target)) + (delete-directory grp-dir) + (setq grp-dir (directory-file-name grp-dir) + dir target) + (unless (eq (aref "/" 0) (aref dir 0)) + (setq dir (concat (file-truename + (nnmaildir--srv-dir nnmaildir--cur-server)) + dir))) + (delete-directory dir) + (nnmaildir--unlink grp-dir))) t))) (defun nnmaildir-retrieve-headers (articles &optional gname server fetch-old) (let ((group (nnmaildir--prepare server gname)) - srv-dir dir nlist mlist article num stop nov nlist2 deactivate-mark) + srv-dir dir nlist mlist article num start stop nov nlist2 insert-nov + deactivate-mark) + (setq insert-nov + (lambda (article) + (setq nov (nnmaildir--update-nov nnmaildir--cur-server group + article)) + (when nov + (nnmaildir--cache-nov group article nov) + (setq num (nnmaildir--art-num article)) + (princ num nntp-server-buffer) + (insert "\t" (nnmaildir--nov-get-beg nov) "\t" + (nnmaildir--art-msgid article) "\t" + (nnmaildir--nov-get-mid nov) "\tXref: nnmaildir " + (gnus-replace-in-string gname " " "\\ " t) ":") + (princ num nntp-server-buffer) + (insert "\t" (nnmaildir--nov-get-end nov) "\n")))) (catch 'return - (if group nil + (unless group (setf (nnmaildir--srv-error nnmaildir--cur-server) (if gname (concat "No such group: " gname) "No current group")) (throw 'return nil)) (nnmaildir--with-nntp-buffer (erase-buffer) - (setq nlist (nnmaildir--grp-lists group) - mlist (nnmaildir--lists-mlist nlist) - nlist (nnmaildir--lists-nlist nlist) + (setq mlist (nnmaildir--grp-mlist group) + nlist (nnmaildir--grp-nlist group) gname (nnmaildir--grp-name group) srv-dir (nnmaildir--srv-dir nnmaildir--cur-server) dir (nnmaildir--srvgrp-dir srv-dir gname)) (cond ((null nlist)) ((and fetch-old (not (numberp fetch-old))) - (while nlist - (setq article (car nlist) nlist (cdr nlist) - nov (nnmaildir--update-nov nnmaildir--cur-server group - article)) - (when nov - (nnmaildir--cache-nov group article nov) - (setq num (nnmaildir--art-num article)) - (princ num nntp-server-buffer) - (insert "\t" (nnmaildir--nov-get-beg nov) "\t" - (nnmaildir--art-msgid article) "\t" - (nnmaildir--nov-get-mid nov) "\tXref: nnmaildir " gname - ":") - (princ num nntp-server-buffer) - (insert "\t" (nnmaildir--nov-get-end nov) "\n") - (goto-char (point-min))))) + (nnmaildir--nlist-iterate nlist 'all insert-nov)) ((null articles)) ((stringp (car articles)) - (while articles - (setq article (car articles) articles (cdr articles) - article (nnmaildir--mlist-art mlist article)) - (when (and article - (setq nov (nnmaildir--update-nov nnmaildir--cur-server - group article))) - (nnmaildir--cache-nov group article nov) - (setq num (nnmaildir--art-num article)) - (princ num nntp-server-buffer) - (insert "\t" (nnmaildir--nov-get-beg nov) "\t" - (nnmaildir--art-msgid article) "\t" - (nnmaildir--nov-get-mid nov) "\tXref: nnmaildir " gname - ":") - (princ num nntp-server-buffer) - (insert "\t" (nnmaildir--nov-get-end nov) "\n")))) + (dolist (msgid articles) + (setq article (nnmaildir--mlist-art mlist msgid)) + (if article (funcall insert-nov article)))) (t (if fetch-old - ;; Assume the article range is sorted ascending + ;; Assume the article range list is sorted ascending (setq stop (car articles) - num (car (last articles)) - stop (if (numberp stop) stop (car stop)) - num (if (numberp num) num (cdr num)) + start (car (last articles)) + stop (if (numberp stop) stop (car stop)) + start (if (numberp start) start (cdr start)) stop (- stop fetch-old) stop (if (< stop 1) 1 stop) - articles (list (cons stop num)))) - (while articles - (setq stop (car articles) articles (cdr articles)) - (while (eq stop (car articles)) - (setq articles (cdr articles))) - (if (numberp stop) (setq num stop) - (setq num (cdr stop) stop (car stop))) - (setq nlist2 (nthcdr (- (nnmaildir--art-num (car nlist)) num) - nlist)) - (while (and nlist2 - (setq article (car nlist2) - num (nnmaildir--art-num article)) - (>= num stop)) - (setq nlist2 (cdr nlist2) - nov (nnmaildir--update-nov nnmaildir--cur-server group - article)) - (when nov - (nnmaildir--cache-nov group article nov) - (princ num nntp-server-buffer) - (insert "\t" (nnmaildir--nov-get-beg nov) "\t" - (nnmaildir--art-msgid article) "\t" - (nnmaildir--nov-get-mid nov) "\tXref: nnmaildir " gname - ":") - (princ num nntp-server-buffer) - (insert "\t" (nnmaildir--nov-get-end nov) "\n") - (goto-char (point-min))))))) + articles (list (cons stop start)))) + (nnmaildir--nlist-iterate nlist articles insert-nov))) (sort-numeric-fields 1 (point-min) (point-max)) 'nov)))) (defun nnmaildir-request-article (num-msgid &optional gname server to-buffer) (let ((group (nnmaildir--prepare server gname)) (case-fold-search t) - list article suffix dir pgname deactivate-mark) + list article dir pgname deactivate-mark) (catch 'return - (if group nil + (unless group (setf (nnmaildir--srv-error nnmaildir--cur-server) (if gname (concat "No such group: " gname) "No current group")) (throw 'return nil)) - (setq list (nnmaildir--grp-lists group)) (if (numberp num-msgid) - (setq list (nnmaildir--lists-nlist list) - article (nnmaildir--nlist-art list num-msgid)) - (setq list (nnmaildir--lists-mlist list) + (setq article (nnmaildir--nlist-art group num-msgid)) + (setq list (nnmaildir--grp-mlist group) article (nnmaildir--mlist-art list num-msgid)) (if article (setq num-msgid (nnmaildir--art-num article)) (catch 'found (mapatoms - (lambda (grp) - (setq group (symbol-value grp) - list (nnmaildir--grp-lists group) - list (nnmaildir--lists-mlist list) + (lambda (group-sym) + (setq group (symbol-value group-sym) + list (nnmaildir--grp-mlist group) article (nnmaildir--mlist-art list num-msgid)) (when article (setq num-msgid (nnmaildir--art-num article)) (throw 'found nil))) - (nnmaildir--srv-groups nnmaildir--cur-server))))) - (if article nil - (setf (nnmaildir--srv-error nnmaildir--cur-server) "No such article") - (throw 'return nil)) - (if (stringp (setq suffix (nnmaildir--art-suffix article))) nil - (setf (nnmaildir--srv-error nnmaildir--cur-server) - "Article has expired") - (throw 'return nil)) + (nnmaildir--srv-groups nnmaildir--cur-server)))) + (unless article + (setf (nnmaildir--srv-error nnmaildir--cur-server) "No such article") + (throw 'return nil))) (setq gname (nnmaildir--grp-name group) pgname (nnmaildir--pgname nnmaildir--cur-server gname) dir (nnmaildir--srv-dir nnmaildir--cur-server) dir (nnmaildir--srvgrp-dir dir gname) - group (if (nnmaildir--param pgname 'read-only) - (nnmaildir--new dir) (nnmaildir--cur dir)) - nnmaildir-article-file-name (concat group - (nnmaildir--art-prefix - article) - suffix)) - (if (file-exists-p nnmaildir-article-file-name) nil - (setf (nnmaildir--art-suffix article) 'expire) - (setf (nnmaildir--art-nov article) nil) + dir (if (nnmaildir--param pgname 'read-only) + (nnmaildir--new dir) (nnmaildir--cur dir)) + nnmaildir-article-file-name + (concat dir + (nnmaildir--art-prefix article) + (nnmaildir--art-suffix article))) + (unless (file-exists-p nnmaildir-article-file-name) + (nnmaildir--expired-article group article) (setf (nnmaildir--srv-error nnmaildir--cur-server) "Article has expired") (throw 'return nil)) - (save-excursion - (set-buffer (or to-buffer nntp-server-buffer)) + (with-current-buffer (or to-buffer nntp-server-buffer) (erase-buffer) (nnheader-insert-file-contents nnmaildir-article-file-name)) (cons gname num-msgid)))) @@ -1199,14 +1371,14 @@ by nnmaildir-request-article.") (let (message-required-mail-headers) (funcall message-send-mail-function))) -(defun nnmaildir-request-replace-article (article gname buffer) +(defun nnmaildir-request-replace-article (number gname buffer) (let ((group (nnmaildir--prepare nil gname)) (coding-system-for-write nnheader-file-coding-system) (buffer-file-coding-system nil) (file-coding-system-alist nil) - file dir suffix tmpfile deactivate-mark) + dir file article suffix tmpfile deactivate-mark) (catch 'return - (if group nil + (unless group (setf (nnmaildir--srv-error nnmaildir--cur-server) (concat "No such group: " gname)) (throw 'return nil)) @@ -1217,51 +1389,42 @@ by nnmaildir-request-article.") (throw 'return nil)) (setq dir (nnmaildir--srv-dir nnmaildir--cur-server) dir (nnmaildir--srvgrp-dir dir gname) - file (nnmaildir--grp-lists group) - file (nnmaildir--lists-nlist file) - file (nnmaildir--nlist-art file article)) - (if (and file (stringp (setq suffix (nnmaildir--art-suffix file)))) - nil + article (nnmaildir--nlist-art group number)) + (unless article (setf (nnmaildir--srv-error nnmaildir--cur-server) - (format "No such article: %d" article)) + (concat "No such article: " (number-to-string number))) (throw 'return nil)) - (save-excursion - (set-buffer buffer) - (setq article file - file (nnmaildir--art-prefix article) - tmpfile (concat (nnmaildir--tmp dir) file)) - (when (file-exists-p tmpfile) - (setf (nnmaildir--srv-error nnmaildir--cur-server) - (concat "File exists: " tmpfile)) - (throw 'return nil)) - (write-region (point-min) (point-max) tmpfile nil 'no-message nil - 'confirm-overwrite)) ;; error would be preferred :( + (setq suffix (nnmaildir--art-suffix article) + file (nnmaildir--art-prefix article) + tmpfile (concat (nnmaildir--tmp dir) file)) + (when (file-exists-p tmpfile) + (setf (nnmaildir--srv-error nnmaildir--cur-server) + (concat "File exists: " tmpfile)) + (throw 'return nil)) + (with-current-buffer buffer + (gmm-write-region (point-min) (point-max) tmpfile nil 'no-message nil + 'excl)) (unix-sync) ;; no fsync :( (rename-file tmpfile (concat (nnmaildir--cur dir) file suffix) 'replace) t))) (defun nnmaildir-request-move-article (article gname server accept-form - &optional last) + &optional last move-is-internal) (let ((group (nnmaildir--prepare server gname)) - pgname list suffix result nnmaildir--file deactivate-mark) + pgname suffix result nnmaildir--file deactivate-mark) (catch 'return - (if group nil + (unless group (setf (nnmaildir--srv-error nnmaildir--cur-server) (concat "No such group: " gname)) (throw 'return nil)) (setq gname (nnmaildir--grp-name group) pgname (nnmaildir--pgname nnmaildir--cur-server gname) - list (nnmaildir--grp-lists group) - list (nnmaildir--lists-nlist list) - article (nnmaildir--nlist-art list article)) - (if article nil + article (nnmaildir--nlist-art group article)) + (unless article (setf (nnmaildir--srv-error nnmaildir--cur-server) "No such article") (throw 'return nil)) - (if (stringp (setq suffix (nnmaildir--art-suffix article))) nil - (setf (nnmaildir--srv-error nnmaildir--cur-server) - "Article has expired") - (throw 'return nil)) - (setq nnmaildir--file (nnmaildir--srv-dir nnmaildir--cur-server) + (setq suffix (nnmaildir--art-suffix article) + nnmaildir--file (nnmaildir--srv-dir nnmaildir--cur-server) nnmaildir--file (nnmaildir--srvgrp-dir nnmaildir--file gname) nnmaildir--file (if (nnmaildir--param pgname 'read-only) (nnmaildir--new nnmaildir--file) @@ -1269,9 +1432,8 @@ by nnmaildir-request-article.") nnmaildir--file (concat nnmaildir--file (nnmaildir--art-prefix article) suffix)) - (if (file-exists-p nnmaildir--file) nil - (setf (nnmaildir--art-suffix article) 'expire) - (setf (nnmaildir--art-nov article) nil) + (unless (file-exists-p nnmaildir--file) + (nnmaildir--expired-article group article) (setf (nnmaildir--srv-error nnmaildir--cur-server) "Article has expired") (throw 'return nil)) @@ -1279,10 +1441,9 @@ by nnmaildir-request-article.") (erase-buffer) (nnheader-insert-file-contents nnmaildir--file) (setq result (eval accept-form))) - (if (or (null result) (nnmaildir--param pgname 'read-only)) nil + (unless (or (null result) (nnmaildir--param pgname 'read-only)) (nnmaildir--unlink nnmaildir--file) - (setf (nnmaildir--art-suffix article) 'expire) - (setf (nnmaildir--art-nov article) nil)) + (nnmaildir--expired-article group article)) result))) (defun nnmaildir-request-accept-article (gname &optional server last) @@ -1290,9 +1451,9 @@ by nnmaildir-request-article.") (coding-system-for-write nnheader-file-coding-system) (buffer-file-coding-system nil) (file-coding-system-alist nil) - srv-dir dir file tmpfile curfile 24h num article) + srv-dir dir file time tmpfile curfile 24h article) (catch 'return - (if group nil + (unless group (setf (nnmaildir--srv-error nnmaildir--cur-server) (concat "No such group: " gname)) (throw 'return nil)) @@ -1304,15 +1465,17 @@ by nnmaildir-request-article.") (throw 'return nil)) (setq srv-dir (nnmaildir--srv-dir nnmaildir--cur-server) dir (nnmaildir--srvgrp-dir srv-dir gname) - file (format-time-string "%s" nil)) - (if (string-equal nnmaildir--delivery-time file) nil + time (current-time) + file (format-time-string "%s." time)) + (unless (string-equal nnmaildir--delivery-time file) (setq nnmaildir--delivery-time file - nnmaildir--delivery-ct 0)) - (setq file (concat file "." nnmaildir--delivery-pid)) - (if (zerop nnmaildir--delivery-ct) nil - (setq file (concat file "_" - (number-to-string nnmaildir--delivery-ct)))) - (setq file (concat file "." (system-name)) + nnmaildir--delivery-count 0)) + (when (and (consp (cdr time)) + (consp (cddr time))) + (setq file (concat file "M" (number-to-string (caddr time))))) + (setq file (concat file nnmaildir--delivery-pid) + file (concat file "Q" (number-to-string nnmaildir--delivery-count)) + file (concat file "." (nnmaildir--system-name)) tmpfile (concat (nnmaildir--tmp dir) file) curfile (concat (nnmaildir--cur dir) file ":2,")) (when (file-exists-p tmpfile) @@ -1323,7 +1486,7 @@ by nnmaildir-request-article.") (setf (nnmaildir--srv-error nnmaildir--cur-server) (concat "File exists: " curfile)) (throw 'return nil)) - (setq nnmaildir--delivery-ct (1+ nnmaildir--delivery-ct) + (setq nnmaildir--delivery-count (1+ nnmaildir--delivery-count) 24h (run-with-timer 86400 nil (lambda () (nnmaildir--unlink tmpfile) @@ -1331,13 +1494,13 @@ by nnmaildir-request-article.") nnmaildir--cur-server) "24-hour timer expired") (throw 'return nil)))) - (condition-case nil - (add-name-to-file nnmaildir--file tmpfile) + (condition-case nil (add-name-to-file nnmaildir--file tmpfile) (error - (write-region (point-min) (point-max) tmpfile nil 'no-message nil - 'confirm-overwrite) ;; error would be preferred :( - (unix-sync))) ;; no fsync :( - (cancel-timer 24h) + (gmm-write-region (point-min) (point-max) tmpfile nil 'no-message nil + 'excl) + (when (fboundp 'unix-sync) + (unix-sync)))) ;; no fsync :( + (nnheader-cancel-timer 24h) (condition-case err (add-name-to-file tmpfile curfile) (error @@ -1346,19 +1509,15 @@ by nnmaildir-request-article.") (nnmaildir--unlink tmpfile) (throw 'return nil))) (nnmaildir--unlink tmpfile) - (setq num (nnmaildir--grp-lists group) - num (nnmaildir--lists-nlist num) - num (1+ (nnmaildir--nlist-last-num num)) - article (make-nnmaildir--art :prefix file :suffix ":2," :num num)) + (setq article (make-nnmaildir--art :prefix file :suffix ":2,")) (if (nnmaildir--grp-add-art nnmaildir--cur-server group article) - (cons gname num))))) + (cons gname (nnmaildir--art-num article)))))) (defun nnmaildir-save-mail (group-art) (catch 'return - (if group-art nil + (unless group-art (throw 'return nil)) - (let ((ret group-art) - ga gname x groups nnmaildir--file deactivate-mark) + (let (ga gname x groups nnmaildir--file deactivate-mark) (save-excursion (goto-char (point-min)) (save-match-data @@ -1371,50 +1530,39 @@ by nnmaildir-request-article.") (or (intern-soft gname groups) (nnmaildir-request-create-group gname) (throw 'return nil)) ;; not that nnmail bothers to check :( - (if (nnmaildir-request-accept-article gname) nil + (unless (nnmaildir-request-accept-article gname) (throw 'return nil)) - (setq x (nnmaildir--prepare nil gname) - nnmaildir--file (nnmaildir--srv-dir nnmaildir--cur-server) - nnmaildir--file (nnmaildir--subdir nnmaildir--file - (nnmaildir--grp-name x)) - x (nnmaildir--grp-lists x) - x (nnmaildir--lists-nlist x) - x (car x) + (setq nnmaildir--file (nnmaildir--srv-dir nnmaildir--cur-server) + nnmaildir--file (nnmaildir--srvgrp-dir nnmaildir--file gname) + x (nnmaildir--prepare nil gname) + x (nnmaildir--grp-nlist x) + x (cdar x) nnmaildir--file (concat nnmaildir--file (nnmaildir--art-prefix x) (nnmaildir--art-suffix x))) - (while group-art - (setq ga (car group-art) group-art (cdr group-art) - gname (car ga)) - (if (and (or (intern-soft gname groups) - (nnmaildir-request-create-group gname)) - (nnmaildir-request-accept-article gname)) nil - (setq ret (delq ga ret)))) ;; We'll still try the other groups - ret))) - -(defun nnmaildir-active-number (group) - (let ((x (nnmaildir--prepare nil group))) - (catch 'return - (if x nil - (setf (nnmaildir--srv-error nnmaildir--cur-server) - (concat "No such group: " group)) - (throw 'return nil)) - (setq x (nnmaildir--grp-lists x) - x (nnmaildir--lists-nlist x)) - (if x - (setq x (car x) - x (nnmaildir--art-num x) - x (1+ x)) - 1)))) + (delq nil + (mapcar + (lambda (ga) + (setq gname (car ga)) + (and (or (intern-soft gname groups) + (nnmaildir-request-create-group gname)) + (nnmaildir-request-accept-article gname) + ga)) + group-art))))) + +(defun nnmaildir-active-number (gname) + 0) + +(declare-function gnus-group-mark-article-read "gnus-group" (group article)) (defun nnmaildir-request-expire-articles (ranges &optional gname server force) (let ((no-force (not force)) (group (nnmaildir--prepare server gname)) - pgname time boundary time-iter bound-iter high low target dir nlist - stop number article didnt suffix nnmaildir--file - nnmaildir-article-file-name deactivate-mark) + pgname time boundary bound-iter high low target dir nlist nlist2 + stop article didnt nnmaildir--file nnmaildir-article-file-name + deactivate-mark) (catch 'return - (if group nil + (unless group (setf (nnmaildir--srv-error nnmaildir--cur-server) (if gname (concat "No such group: " gname) "No current group")) (throw 'return (gnus-uncompress-range ranges))) @@ -1422,224 +1570,220 @@ by nnmaildir-request-article.") pgname (nnmaildir--pgname nnmaildir--cur-server gname)) (if (nnmaildir--param pgname 'read-only) (throw 'return (gnus-uncompress-range ranges))) - (setq time (or (nnmaildir--param pgname 'expire-age) - (* 86400 ;; seconds per day - (or (and nnmail-expiry-wait-function - (funcall nnmail-expiry-wait-function gname)) - nnmail-expiry-wait)))) - (if (or force (integerp time)) nil - (throw 'return (gnus-uncompress-range ranges))) - (setq boundary (current-time) - high (- (car boundary) (/ time 65536)) - low (- (cadr boundary) (% time 65536))) - (if (< low 0) - (setq low (+ low 65536) - high (1- high))) - (setcar (cdr boundary) low) - (setcar boundary high) + (setq time (nnmaildir--param pgname 'expire-age)) + (unless time + (setq time (or (and nnmail-expiry-wait-function + (funcall nnmail-expiry-wait-function gname)) + nnmail-expiry-wait)) + (if (eq time 'immediate) + (setq time 0) + (if (numberp time) + (setq time (round (* time 86400)))))) + (when no-force + (unless (integerp time) ;; handle 'never + (throw 'return (gnus-uncompress-range ranges))) + (setq boundary (current-time) + high (- (car boundary) (/ time 65536)) + low (- (cadr boundary) (% time 65536))) + (if (< low 0) + (setq low (+ low 65536) + high (1- high))) + (setcar (cdr boundary) low) + (setcar boundary high)) (setq dir (nnmaildir--srv-dir nnmaildir--cur-server) dir (nnmaildir--srvgrp-dir dir gname) dir (nnmaildir--cur dir) - nlist (nnmaildir--grp-lists group) - nlist (nnmaildir--lists-nlist nlist) + nlist (nnmaildir--grp-nlist group) ranges (reverse ranges)) (nnmaildir--with-move-buffer - (while ranges - (setq number (car ranges) ranges (cdr ranges)) - (while (eq number (car ranges)) - (setq ranges (cdr ranges))) - (if (numberp number) (setq stop number) - (setq stop (car number) number (cdr number))) - (setq nlist (nthcdr (- (nnmaildir--art-num (car nlist)) number) - nlist)) - (while (and nlist - (setq article (car nlist) - number (nnmaildir--art-num article)) - (>= number stop)) - (setq nlist (cdr nlist) - suffix (nnmaildir--art-suffix article)) - (catch 'continue - (if (stringp suffix) nil - (setf (nnmaildir--art-suffix article) 'expire) - (setf (nnmaildir--art-nov article) nil) - (throw 'continue nil)) - (setq nnmaildir--file (nnmaildir--art-prefix article) - nnmaildir--file (concat dir nnmaildir--file suffix) - time (file-attributes nnmaildir--file)) - (if time nil - (setf (nnmaildir--art-suffix article) 'expire) - (setf (nnmaildir--art-nov article) nil) - (throw 'continue nil)) - (setq time (nth 5 time) - time-iter time - bound-iter boundary) - (if (and no-force - (progn - (while (and bound-iter time-iter - (= (car bound-iter) (car time-iter))) - (setq bound-iter (cdr bound-iter) - time-iter (cdr time-iter))) - (and bound-iter time-iter - (car-less-than-car bound-iter time-iter)))) - (setq didnt (cons number didnt)) - (save-excursion - (setq nnmaildir-article-file-name nnmaildir--file - target (nnmaildir--param pgname 'expire-group))) - (when (and (stringp target) - (not (string-equal target pgname))) ;; Move it. - (erase-buffer) - (nnheader-insert-file-contents nnmaildir--file) - (gnus-request-accept-article target nil nil 'no-encode)) - (if (equal target pgname) - (setq didnt (cons number didnt)) ;; Leave it here. - (nnmaildir--unlink nnmaildir--file) - (setf (nnmaildir--art-suffix article) 'expire) - (setf (nnmaildir--art-nov article) nil)))))) + (nnmaildir--nlist-iterate + nlist ranges + (lambda (article) + (setq nnmaildir--file (nnmaildir--art-prefix article) + nnmaildir--file (concat dir nnmaildir--file + (nnmaildir--art-suffix article)) + time (file-attributes nnmaildir--file)) + (cond + ((null time) + (nnmaildir--expired-article group article)) + ((and no-force + (progn + (setq time (nth 5 time) + bound-iter boundary) + (while (and bound-iter time + (= (car bound-iter) (car time))) + (setq bound-iter (cdr bound-iter) + time (cdr time))) + (and bound-iter time + (car-less-than-car bound-iter time)))) + (setq didnt (cons (nnmaildir--art-num article) didnt))) + (t + (setq nnmaildir-article-file-name nnmaildir--file + target (if force nil + (save-excursion + (save-restriction + (nnmaildir--param pgname 'expire-group))))) + (when (and (stringp target) + (not (string-equal target pgname))) ;; Move it. + (erase-buffer) + (nnheader-insert-file-contents nnmaildir--file) + (let ((group-art (gnus-request-accept-article + target nil nil 'no-encode))) + (when (consp group-art) + ;; Maybe also copy: dormant forward reply save tick + ;; (gnus-add-mark? gnus-request-set-mark?) + (gnus-group-mark-article-read target (cdr group-art))))) + (if (equal target pgname) + ;; Leave it here. + (setq didnt (cons (nnmaildir--art-num article) didnt)) + (nnmaildir--unlink nnmaildir--file) + (nnmaildir--expired-article group article)))))) (erase-buffer)) didnt))) (defun nnmaildir-request-set-mark (gname actions &optional server) - (let ((group (nnmaildir--prepare server gname)) - (coding-system-for-write nnheader-file-coding-system) - (buffer-file-coding-system nil) - (file-coding-system-alist nil) - del-mark add-marks marksdir markfile action group-nlist nlist ranges - begin end article all-marks todo-marks did-marks marks form mdir mfile - pgname ls markfilenew deactivate-mark) + (let* ((group (nnmaildir--prepare server gname)) + (curdir (nnmaildir--cur + (nnmaildir--srvgrp-dir + (nnmaildir--srv-dir nnmaildir--cur-server) + gname))) + (coding-system-for-write nnheader-file-coding-system) + (buffer-file-coding-system nil) + (file-coding-system-alist nil) + del-mark del-action add-action set-action marksdir nlist + ranges begin end article all-marks todo-marks mdir mfile + pgname ls permarkfile deactivate-mark) (setq del-mark - (lambda () - (setq mfile (nnmaildir--subdir marksdir (symbol-name (car marks))) - mfile (concat mfile (nnmaildir--art-prefix article))) - (nnmaildir--unlink mfile)) - add-marks - (lambda () - (while marks - (setq mdir (nnmaildir--subdir marksdir (symbol-name (car marks))) - mfile (concat mdir (nnmaildir--art-prefix article))) - (if (memq (car marks) did-marks) nil - (nnmaildir--mkdir mdir) - (setq did-marks (cons (car marks) did-marks))) - (if (file-exists-p mfile) nil - (condition-case nil - (add-name-to-file markfile mfile) - (file-error - (if (file-exists-p mfile) nil - ;; too many links, maybe - (write-region "" nil markfilenew nil 'no-message) - (add-name-to-file markfilenew mfile 'ok-if-already-exists) - (rename-file markfilenew markfile 'replace))))) - (setq marks (cdr marks))))) + (lambda (mark) + (let ((prefix (nnmaildir--art-prefix article)) + (suffix (nnmaildir--art-suffix article)) + (flag (nnmaildir--mark-to-flag mark))) + (when flag + ;; If this mark corresponds to a flag, remove the flag from + ;; the file name. + (nnmaildir--article-set-flags + article (nnmaildir--remove-flag flag suffix) curdir)) + ;; We still want to delete the hardlink in the marks dir if + ;; present, regardless of whether this mark has a maildir flag or + ;; not, to avoid getting out of sync. + (setq mfile (nnmaildir--subdir marksdir (symbol-name mark)) + mfile (concat mfile prefix)) + (nnmaildir--unlink mfile))) + del-action (lambda (article) (mapcar del-mark todo-marks)) + add-action + (lambda (article) + (mapcar + (lambda (mark) + (let ((prefix (nnmaildir--art-prefix article)) + (suffix (nnmaildir--art-suffix article)) + (flag (nnmaildir--mark-to-flag mark))) + (if flag + ;; If there is a corresponding maildir flag, just rename + ;; the file. + (nnmaildir--article-set-flags + article (nnmaildir--add-flag flag suffix) curdir) + ;; Otherwise, use nnmaildir-specific marks dir. + (setq mdir (nnmaildir--subdir marksdir (symbol-name mark)) + permarkfile (concat mdir ":") + mfile (concat mdir prefix)) + (nnmaildir--condcase err (add-name-to-file permarkfile mfile) + (cond + ((nnmaildir--eexist-p err)) + ((nnmaildir--enoent-p err) + (nnmaildir--mkdir mdir) + (nnmaildir--mkfile permarkfile) + (add-name-to-file permarkfile mfile)) + ((nnmaildir--emlink-p err) + (let ((permarkfilenew (concat permarkfile "{new}"))) + (nnmaildir--mkfile permarkfilenew) + (rename-file permarkfilenew permarkfile 'replace) + (add-name-to-file permarkfile mfile))) + (t (signal (car err) (cdr err)))))))) + todo-marks)) + set-action (lambda (article) + (funcall add-action article) + (mapcar (lambda (mark) + (unless (memq mark todo-marks) + (funcall del-mark mark))) + all-marks))) (catch 'return - (if group nil + (unless group (setf (nnmaildir--srv-error nnmaildir--cur-server) (concat "No such group: " gname)) - (while actions - (setq ranges (gnus-range-add ranges (caar actions)) - actions (cdr actions))) + (dolist (action actions) + (setq ranges (gnus-range-add ranges (car action)))) (throw 'return ranges)) - (setq group-nlist (nnmaildir--grp-lists group) - group-nlist (nnmaildir--lists-nlist group-nlist) + (setq nlist (nnmaildir--grp-nlist group) marksdir (nnmaildir--srv-dir nnmaildir--cur-server) marksdir (nnmaildir--srvgrp-dir marksdir gname) marksdir (nnmaildir--nndir marksdir) - markfile (concat marksdir "markfile") - markfilenew (concat markfile "{new}") marksdir (nnmaildir--marks-dir marksdir) gname (nnmaildir--grp-name group) pgname (nnmaildir--pgname nnmaildir--cur-server gname) ls (nnmaildir--group-ls nnmaildir--cur-server pgname) all-marks (funcall ls marksdir nil "\\`[^.]" 'nosort) - marks all-marks) - (while marks - (setcar marks (intern (car marks))) - (setq marks (cdr marks))) - (while actions - (setq action (car actions) actions (cdr actions) - nlist group-nlist - ranges (car action) - todo-marks (caddr action) - marks todo-marks) - (while marks - (if (memq (car marks) all-marks) nil - (setq all-marks (cons (car marks) all-marks))) - (setq marks (cdr marks))) - (setq form - (cond - ((eq 'del (cadr action)) - '(while marks - (funcall del-mark) - (setq marks (cdr marks)))) - ((eq 'add (cadr action)) '(funcall add-marks)) - (t - '(progn - (funcall add-marks) - (setq marks all-marks) - (while marks - (if (memq (car marks) todo-marks) nil - (funcall del-mark)) - (setq marks (cdr marks))))))) - (if (numberp (cdr ranges)) (setq ranges (list ranges)) - (setq ranges (reverse ranges))) - (while ranges - (setq begin (car ranges) ranges (cdr ranges)) - (while (eq begin (car ranges)) - (setq ranges (cdr ranges))) - (if (numberp begin) (setq end begin) - (setq end (cdr begin) begin (car begin))) - (setq nlist (nthcdr (- (nnmaildir--art-num (car nlist)) end) - nlist)) - (while (and nlist - (setq article (car nlist)) - (>= (nnmaildir--art-num article) begin)) - (setq nlist (cdr nlist)) - (when (stringp (nnmaildir--art-suffix article)) - (setq marks todo-marks) - (eval form))))) + all-marks (gnus-delete-duplicates + ;; get mark names from mark dirs and from flag + ;; mappings + (append + (mapcar 'cdr nnmaildir-flag-mark-mapping) + (mapcar 'intern all-marks)))) + (dolist (action actions) + (setq ranges (car action) + todo-marks (caddr action)) + (dolist (mark todo-marks) + (add-to-list 'all-marks mark)) + (if (numberp (cdr ranges)) (setq ranges (list ranges))) + (nnmaildir--nlist-iterate nlist ranges + (cond ((eq 'del (cadr action)) del-action) + ((eq 'add (cadr action)) add-action) + ((eq 'set (cadr action)) set-action)))) nil))) -(defun nnmaildir-close-group (group &optional server) - t) +(defun nnmaildir-close-group (gname &optional server) + (let ((group (nnmaildir--prepare server gname)) + pgname ls dir msgdir files flist dirs) + (if (null group) + (progn + (setf (nnmaildir--srv-error nnmaildir--cur-server) + (concat "No such group: " gname)) + nil) + (setq pgname (nnmaildir--pgname nnmaildir--cur-server gname) + ls (nnmaildir--group-ls nnmaildir--cur-server pgname) + dir (nnmaildir--srv-dir nnmaildir--cur-server) + dir (nnmaildir--srvgrp-dir dir gname) + msgdir (if (nnmaildir--param pgname 'read-only) + (nnmaildir--new dir) (nnmaildir--cur dir)) + dir (nnmaildir--nndir dir) + dirs (cons (nnmaildir--nov-dir dir) + (funcall ls (nnmaildir--marks-dir dir) 'full "\\`[^.]" + 'nosort)) + dirs (mapcar + (lambda (dir) + (cons dir (funcall ls dir nil "\\`[^.]" 'nosort))) + dirs) + files (funcall ls msgdir nil "\\`[^.]" 'nosort) + flist (nnmaildir--up2-1 (length files)) + flist (make-vector flist 0)) + (save-match-data + (dolist (file files) + (string-match "\\`\\([^:]*\\)\\(:.*\\)?\\'" file) + (intern (match-string 1 file) flist))) + (dolist (dir dirs) + (setq files (cdr dir) + dir (file-name-as-directory (car dir))) + (dolist (file files) + (unless (or (intern-soft file flist) (string= file ":")) + (setq file (concat dir file)) + (delete-file file)))) + t))) (defun nnmaildir-close-server (&optional server) (let (flist ls dirs dir files file x) (nnmaildir--prepare server nil) - (setq server nnmaildir--cur-server) - (when server - (setq nnmaildir--cur-server nil) - (save-match-data - (mapatoms - (lambda (group) - (setq x (nnmaildir--pgname server (symbol-name group)) - group (symbol-value group) - ls (nnmaildir--group-ls server x) - dir (nnmaildir--srv-dir server) - dir (nnmaildir--srvgrp-dir dir (nnmaildir--grp-name group)) - x (nnmaildir--param x 'read-only) - x (if x (nnmaildir--new dir) (nnmaildir--cur dir)) - files (funcall ls x nil "\\`[^.]" 'nosort) - x (length files) - flist 1) - (while (<= flist x) (setq flist (* 2 flist))) - (if (/= flist 1) (setq flist (1- flist))) - (setq flist (make-vector flist 0)) - (while files - (setq file (car files) files (cdr files)) - (string-match "\\`\\([^:]*\\)\\(:.*\\)?\\'" file) - (intern (match-string 1 file) flist)) - (setq dir (nnmaildir--nndir dir) - dirs (cons (nnmaildir--nov-dir dir) - (funcall ls (nnmaildir--marks-dir dir) 'full - "\\`[^.]" 'nosort))) - (while dirs - (setq dir (car dirs) dirs (cdr dirs) - files (funcall ls dir nil "\\`[^.]" 'nosort) - dir (file-name-as-directory dir)) - (while files - (setq file (car files) files (cdr files)) - (if (intern-soft file flist) nil - (setq file (concat dir file)) - (delete-file file))))) - (nnmaildir--srv-groups server))) + (when nnmaildir--cur-server + (setq server nnmaildir--cur-server + nnmaildir--cur-server nil) (unintern (nnmaildir--srv-address server) nnmaildir--servers))) t) @@ -1648,9 +1792,7 @@ by nnmaildir-request-article.") (mapatoms (lambda (server) (setq servers (cons (symbol-name server) servers))) nnmaildir--servers) - (while servers - (nnmaildir-close-server (car servers)) - (setq servers (cdr servers))) + (mapc 'nnmaildir-close-server servers) (setq buffer (get-buffer " *nnmaildir work*")) (if buffer (kill-buffer buffer)) (setq buffer (get-buffer " *nnmaildir nov*")) @@ -1659,28 +1801,11 @@ by nnmaildir-request-article.") (if buffer (kill-buffer buffer))) t) -(defun nnmaildir--edit-prep () - (let ((extras '(mapcar mapatoms)) - name) - (mapatoms - (lambda (sym) - (when (or (memq sym extras) - (and (fboundp sym) - (setq name (symbol-name sym)) - (>= (length name) 10) - (or (string-equal "nnmaildir-" (substring name 0 10)) - (and (>= (length name) 15) - (string-equal "make-nnmaildir-" - (substring name 0 15)))))) - (put sym 'lisp-indent-function 0)))) - 'done)) - (provide 'nnmaildir) ;; Local Variables: ;; indent-tabs-mode: t ;; fill-column: 77 -;; eval: (progn (require 'nnmaildir) (nnmaildir--edit-prep)) ;; End: ;;; nnmaildir.el ends here