;;; nnmaildir.el --- maildir backend for Gnus
-;; Public domain.
+
+;; This file is in the public domain.
;; Author: Paul Jarc <prj@po.cwru.edu>
;; This file is part of GNU Emacs.
-;; GNU Emacs is free software; you can redistribute it and/or modify
+;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-;; Boston, MA 02110-1301, USA.
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
)
]
+;; 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)
(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.")
(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))
(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"))
-(defmacro nnmaildir--num-dir (dir) `(nnmaildir--subdir ,dir "num"))
+(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))
(write-region "" nil file nil 'no-message))
(defun nnmaildir--delete-dir-files (dir ls)
(when (file-attributes dir)
- (mapcar 'delete-file (funcall ls dir 'full "\\`[^.]" 'nosort))
+ (mapc 'delete-file (funcall ls dir 'full "\\`[^.]" 'nosort))
(delete-directory dir)))
(defun nnmaildir--group-maxnum (server group)
(setq attr (file-attributes
(concat dir (number-to-string number-linked))))
(or attr (throw 'return (1- number-linked)))
- (if (/= ino-opened (nth 10 attr))
- (setq number-opened 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
string)
(defmacro nnmaildir--condcase (errsym body &rest handler)
+ (declare (debug (sexp form body)))
`(condition-case ,errsym
(let ((system-messages-locale "C")) ,body)
(error . ,handler)))
number-open number-link))
((nnmaildir--eexist-p err)
(let ((attr (file-attributes path-link)))
- (if (/= (nth 10 attr) ino-open)
- (setq number-open number-link
- number-link 0))))
+ (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)
ls (or (nnmaildir--param pgname 'directory-files) srv-ls))
(unless read-only
(setq x (nth 11 (file-attributes tdir)))
- (unless (and (= x (nth 11 nattr)) (= x (nth 11 cattr)))
+ (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))
- (mapcar
- (lambda (file)
- (setq x (file-attributes file))
- (if (or (> (cadr x) 1) (< (car (nth 4 x)) 36h-ago))
- (delete-file file)))
- (funcall ls tdir 'full "\\`[^.]" 'nosort)))
+ (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
(throw 'return t))
(setq nattr nil))
(if read-only (setq dir (and (or isnew nattr) ndir))
(when (or isnew nattr)
- (mapcar
- (lambda (file)
- (let ((path (concat ndir file)))
- (and (time-less-p (nth 5 (file-attributes path)) (current-time))
- (rename-file path (concat cdir file ":2,")))))
- (funcall ls ndir nil "\\`[^.]" 'nosort))
+ (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))
cdir (nnmaildir--marks-dir nndir)
ndir (nnmaildir--subdir cdir "tick")
cdir (nnmaildir--subdir cdir "read"))
- (mapcar
- (lambda (file)
- (setq file (car file))
- (if (or (not (file-exists-p (concat cdir file)))
- (file-exists-p (concat ndir file)))
- (setq num (1+ num))))
- files))
+ (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))
files (delq nil files)
files (mapcar 'nnmaildir--parse-filename files)
files (sort files 'nnmaildir--sort-files))
- (mapcar
- (lambda (file)
- (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))
- files)
+ (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))
dirs))
seen (nnmaildir--up2-1 (length dirs))
seen (make-vector seen 0))
- (mapcar
- (lambda (grp-dir)
- (if (nnmaildir--scan grp-dir scan-group groups method srv-dir
- srv-ls)
- (intern grp-dir seen)))
- dirs)
+ (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))
(unless (intern-soft group seen)
(setq x (cons group x))))
groups)
- (mapcar (lambda (grp) (unintern grp groups)) x)
+ (dolist (grp x)
+ (unintern grp groups))
(setf (nnmaildir--srv-mtime nnmaildir--cur-server)
(nth 5 (file-attributes srv-dir))))
(and scan-group
pgname (nnmaildir--pgname nnmaildir--cur-server pgname)
group (symbol-value group)
ro (nnmaildir--param pgname 'read-only))
- (insert (nnmaildir--grp-name group) " ")
+ (insert (gnus-replace-in-string
+ (nnmaildir--grp-name group) " " "\\ " t)
+ " ")
(princ (nnmaildir--group-maxnum nnmaildir--cur-server group)
nntp-server-buffer)
(insert " ")
(nnmaildir--prepare server nil)
(nnmaildir--with-nntp-buffer
(erase-buffer)
- (mapcar
- (lambda (gname)
- (setq group (nnmaildir--prepare nil gname))
- (if (null group) (insert "411 no such news group\n")
- (insert "211 ")
- (princ (nnmaildir--grp-count group) nntp-server-buffer)
- (insert " ")
- (princ (nnmaildir--grp-min group) nntp-server-buffer)
- (insert " ")
- (princ (nnmaildir--group-maxnum nnmaildir--cur-server group)
- nntp-server-buffer)
- (insert " " gname "\n")))
- groups)))
+ (dolist (gname groups)
+ (setq group (nnmaildir--prepare nil gname))
+ (if (null group) (insert "411 no such news group\n")
+ (insert "211 ")
+ (princ (nnmaildir--grp-count group) nntp-server-buffer)
+ (insert " ")
+ (princ (nnmaildir--grp-min group) nntp-server-buffer)
+ (insert " ")
+ (princ (nnmaildir--group-maxnum nnmaildir--cur-server group)
+ nntp-server-buffer)
+ (insert " "
+ (gnus-replace-in-string gname " " "\\ " t)
+ "\n")))))
'group)
(defun nnmaildir-request-update-info (gname info &optional server)
- (let ((group (nnmaildir--prepare server gname))
- pgname flist always-marks never-marks old-marks dotfile num dir
- markdirs marks mark ranges markdir article read end new-marks ls
- old-mmth new-mmth mtime mark-sym existing missing 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
(unless group
(setf (nnmaildir--srv-error nnmaildir--cur-server)
dir (nnmaildir--nndir dir)
dir (nnmaildir--marks-dir dir)
ls (nnmaildir--group-ls nnmaildir--cur-server pgname)
- markdirs (funcall ls dir nil "\\`[^.]" 'nosort)
- new-mmth (nnmaildir--up2-1 (length markdirs))
+ 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))
- (mapcar
- (lambda (mark)
- (setq markdir (nnmaildir--subdir dir mark)
- mark-sym (intern mark)
- ranges nil)
- (catch 'got-ranges
- (if (memq mark-sym never-marks) (throw 'got-ranges nil))
- (when (memq mark-sym always-marks)
- (setq ranges existing)
- (throw 'got-ranges nil))
- (setq mtime (nth 5 (file-attributes markdir)))
- (set (intern mark new-mmth) mtime)
- (when (equal mtime (symbol-value (intern-soft mark old-mmth)))
- (setq ranges (assq mark-sym old-marks))
- (if ranges (setq ranges (cdr ranges)))
- (throw 'got-ranges nil))
- (mapcar
- (lambda (prefix)
- (setq article (nnmaildir--flist-art flist prefix))
- (if article
- (setq ranges
- (gnus-add-to-range ranges
- `(,(nnmaildir--art-num article))))))
- (funcall ls markdir nil "\\`[^.]" 'nosort)))
- (if (eq mark-sym 'read) (setq read ranges)
- (if ranges (setq marks (cons (cons mark-sym ranges) marks)))))
- markdirs)
+ (dolist (mark all-marks)
+ (setq markdir (nnmaildir--subdir dir (symbol-name mark))
+ ranges nil)
+ (catch 'got-ranges
+ (if (memq mark never-marks) (throw 'got-ranges nil))
+ (when (memq mark always-marks)
+ (setq ranges existing)
+ (throw 'got-ranges nil))
+ ;; 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))
+ (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)
+(defun nnmaildir-request-group (gname &optional server fast info)
(let ((group (nnmaildir--prepare server gname))
deactivate-mark)
(catch 'return
(insert " ")
(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--delete-dir-files (nnmaildir--new grp-dir) ls)
(nnmaildir--delete-dir-files (nnmaildir--cur grp-dir) ls))
(setq dir (nnmaildir--nndir grp-dir))
- (mapcar (lambda (subdir) (nnmaildir--delete-dir-files subdir ls))
- `(,(nnmaildir--nov-dir dir) ,(nnmaildir--num-dir dir)
- ,@(funcall ls (nnmaildir--marks-dir dir) 'full "\\`[^.]"
- 'nosort)))
+ (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}"))
(insert "\t" (nnmaildir--nov-get-beg nov) "\t"
(nnmaildir--art-msgid article) "\t"
(nnmaildir--nov-get-mid nov) "\tXref: nnmaildir "
- gname ":")
+ (gnus-replace-in-string gname " " "\\ " t) ":")
(princ num nntp-server-buffer)
(insert "\t" (nnmaildir--nov-get-end nov) "\n"))))
(catch 'return
(nnmaildir--nlist-iterate nlist 'all insert-nov))
((null articles))
((stringp (car articles))
- (mapcar
- (lambda (msgid)
- (setq article (nnmaildir--mlist-art mlist msgid))
- (if article (funcall insert-nov article)))
- articles))
+ (dolist (msgid articles)
+ (setq article (nnmaildir--mlist-art mlist msgid))
+ (if article (funcall insert-nov article))))
(t
(if fetch-old
;; Assume the article range list is sorted ascending
(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))))
(setf (nnmaildir--srv-error nnmaildir--cur-server)
(concat "File exists: " tmpfile))
(throw 'return nil))
- (save-excursion
- (set-buffer buffer)
+ (with-current-buffer buffer
(gmm-write-region (point-min) (point-max) tmpfile nil 'no-message nil
'excl))
(unix-sync) ;; no fsync :(
(error
(gmm-write-region (point-min) (point-max) tmpfile nil 'no-message nil
'excl)
- (unix-sync))) ;; no fsync :(
+ (when (fboundp 'unix-sync)
+ (unix-sync)))) ;; no fsync :(
(nnheader-cancel-timer 24h)
(condition-case err
(add-name-to-file tmpfile curfile)
(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))
(if (eq time 'immediate)
(setq time 0)
(if (numberp time)
- (setq time (* time 86400)))))
+ (setq time (round (* time 86400))))))
(when no-force
(unless (integerp time) ;; handle 'never
(throw 'return (gnus-uncompress-range ranges)))
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 del-action add-action set-action marksdir nlist
- ranges begin end article all-marks todo-marks mdir mfile
- pgname ls permarkfile 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 (mark)
- (setq mfile (nnmaildir--subdir marksdir (symbol-name mark))
- mfile (concat mfile (nnmaildir--art-prefix article)))
- (nnmaildir--unlink mfile))
+ (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)
- (setq mdir (nnmaildir--subdir marksdir (symbol-name mark))
- permarkfile (concat mdir ":")
- mfile (concat mdir (nnmaildir--art-prefix article)))
- (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))))))
+ (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)
+ (funcall add-action article)
(mapcar (lambda (mark)
(unless (memq mark todo-marks)
(funcall del-mark mark)))
(unless group
(setf (nnmaildir--srv-error nnmaildir--cur-server)
(concat "No such group: " gname))
- (mapcar (lambda (action)
- (setq ranges (gnus-range-add ranges (car action))))
- actions)
+ (dolist (action actions)
+ (setq ranges (gnus-range-add ranges (car action))))
(throw 'return ranges))
(setq nlist (nnmaildir--grp-nlist group)
marksdir (nnmaildir--srv-dir nnmaildir--cur-server)
pgname (nnmaildir--pgname nnmaildir--cur-server gname)
ls (nnmaildir--group-ls nnmaildir--cur-server pgname)
all-marks (funcall ls marksdir nil "\\`[^.]" 'nosort)
- all-marks (mapcar 'intern all-marks))
- (mapcar
- (lambda (action)
- (setq ranges (car action)
- todo-marks (caddr action))
- (mapcar (lambda (mark) (add-to-list 'all-marks mark)) todo-marks)
- (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)
- (t set-action))))
- actions)
+ 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 (gname &optional server)
flist (nnmaildir--up2-1 (length files))
flist (make-vector flist 0))
(save-match-data
- (mapcar
- (lambda (file)
- (string-match "\\`\\([^:]*\\)\\(:.*\\)?\\'" file)
- (intern (match-string 1 file) flist))
- files))
- (mapcar
- (lambda (dir)
- (setq files (cdr dir)
- dir (file-name-as-directory (car dir)))
- (mapcar
- (lambda (file)
- (unless (or (intern-soft file flist) (string= file ":"))
- (setq file (concat dir file))
- (delete-file file)))
- files))
- dirs)
+ (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)
(mapatoms (lambda (server)
(setq servers (cons (symbol-name server) servers)))
nnmaildir--servers)
- (mapcar 'nnmaildir-close-server servers)
+ (mapc 'nnmaildir-close-server servers)
(setq buffer (get-buffer " *nnmaildir work*"))
(if buffer (kill-buffer buffer))
(setq buffer (get-buffer " *nnmaildir nov*"))
;; fill-column: 77
;; End:
-;;; arch-tag: 0c4e44cd-dfde-4040-888e-5597ec771849
;;; nnmaildir.el ends here
projects / gnus / blobdiff