;;; nnmaildir.el --- maildir backend for Gnus
-;; Public domain.
+
+;; This file is in the public domain.
;; Author: Paul Jarc <prj@po.cwru.edu>
;; 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)
+;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; copying, restoring, etc.
;;
;; Todo:
-;; * Merge the information from <URL:http://multivac.cwru.edu./nnmaildir/>
-;; into the Gnus manual.
-;; * Allow create-directory = ".", and configurable prefix of maildir names,
-;; stripped off to produce group names.
+;; * 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.
-;; * Allow each mark directory in a group to have its own inode for mark
-;; files, to accommodate AFS.
;; * Improve generated Xrefs, so crossposts are detectable.
+;; * Improve code readability.
;;; Code:
(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)
)
]
;; 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:
; ("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
+ (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--expired-article (group article)
(setf (nnmaildir--art-nov article) nil)
(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"))
-(defmacro nnmaildir--num-file (dir) `(concat ,dir ":"))
(defmacro nnmaildir--unlink (file-arg)
`(let ((file ,file-arg))
(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)
- (mapcar 'delete-file (funcall ls dir 'full "\\`[^.]" 'nosort))
- (delete-directory dir))
+ (when (file-attributes dir)
+ (mapc 'delete-file (funcall ls dir 'full "\\`[^.]" 'nosort))
+ (delete-directory dir)))
(defun nnmaildir--group-maxnum (server group)
- (let ((x (nnmaildir--srvgrp-dir (nnmaildir--srv-dir server)
- (nnmaildir--grp-name group))))
- (setq x (nnmaildir--nndir x)
- x (nnmaildir--num-dir x)
- x (nnmaildir--num-file x)
- x (file-attributes x))
- (if x (1- (nth 1 x)) 0)))
+ (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)))
+ (if (/= 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
(setq pos (match-end 0))))
string)
+(defmacro nnmaildir--condcase (errsym body &rest handler)
+ `(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)))
+ (if (/= (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))
(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)))
(unless (or (zerop field) (nnmaildir--param pgname 'distrust-Lines:))
(setq nov-mid field))
nov-end (mapconcat
(lambda (extra)
(setq field (symbol-name (car extra))
- val (cdr field))
+ val (cdr extra))
(nnmaildir--tab-to-space field)
(nnmaildir--tab-to-space val)
(concat field ": " val))
nnmaildir--extra)
num (nnmaildir--art-num article))
(unless num
- ;; Allocate a new article number.
- (erase-buffer)
- (setq numdir (nnmaildir--num-dir dir)
- file (nnmaildir--num-file numdir)
- num -1)
- (nnmaildir--mkdir numdir)
- (write-region "" nil file nil 'no-message)
- (while file
- ;; Get the number of links to file.
- (setq attr (nth 1 (file-attributes file)))
- (if (= attr num)
- ;; We've already tried this number, in the previous loop
- ;; iteration, and failed.
- (signal 'error `("Corrupt internal nnmaildir data" ,numdir)))
- ;; If attr is 123, try to link file to "123". This atomically
- ;; increases the link count and creates the "123" link, failing
- ;; if that link was already created by another Gnus, just after
- ;; we stat()ed file.
- (condition-case nil
- (progn
- (add-name-to-file file (concat numdir (format "%x" attr)))
- (setq file nil)) ;; Stop looping.
- (file-already-exists nil))
- (setq num attr))
+ (setq num (nnmaildir--new-number dir))
(setf (nnmaildir--art-num article) num))
;; Store this new NOV data in a file
(erase-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 nil 'excl))
+ (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)))
count num min nlist nlist-cdr insert-nlist)
(when nov
(setq count (1+ (nnmaildir--grp-count group))
- min (nnmaildir--grp-min group)
- num (nnmaildir--art-num article))
- (setq min (min min num))
- (setq nlist (nnmaildir--grp-nlist 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 (< num (caar nlist-cdr))
+ (while (and nlist-cdr (< num (caar nlist-cdr)))
(setq nlist nlist-cdr
nlist-cdr (cdr nlist))))
(let ((inhibit-quit t))
(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)
(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)))
(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)))
(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
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))
(unless read-only
(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)
- (rename-file (concat ndir file) (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 file ":2,"))))
(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 (file files)
+ (setq file (car file))
+ (if (or (not (file-exists-p (concat cdir file)))
+ (file-exists-p (concat ndir file)))
+ (setq num (1+ 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 5))
- 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))
(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)
method srv-dir srv-ls))
groups))
(setq dirs (funcall srv-ls srv-dir nil "\\`[^.]" 'nosort)
+ 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))
- (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 all always-marks never-marks old-marks dotfile num dir
+ 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 deactivate-mark)
+ old-mmth new-mmth mtime mark-sym existing missing deactivate-mark
+ article-list)
(catch 'return
(unless group
(setf (nnmaildir--srv-error nnmaildir--cur-server)
old-marks (cons old-marks (gnus-info-marks info))
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)
new-mmth (nnmaildir--up2-1 (length markdirs))
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)
- (unless all
- (setq all (nnmaildir--grp-nlist group)
- all (mapcar 'car all)
- all (nreverse all)
- all (gnus-compress-sequence all 'always-list)
- all (cons 'dummy-mark-symbol all)))
- (setq ranges (cdr all))
- (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)
- (gnus-info-set-read info read)
+ (dolist (mark markdirs)
+ (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))
+ (setq article-list nil)
+ (dolist (prefix (funcall ls markdir nil "\\`[^.]" 'nosort))
+ (setq article (nnmaildir--flist-art flist prefix))
+ (if article
+ (setq article-list
+ (cons (nnmaildir--art-num article) article-list))))
+ (setq ranges (gnus-add-to-range ranges (sort article-list '<))))
+ (if (eq mark-sym 'read) (setq read ranges)
+ (if ranges (setq marks (cons (cons mark-sym 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)
(let ((group (nnmaildir--prepare server gname))
deactivate-mark)
- (nnmaildir--with-nntp-buffer
- (erase-buffer)
- (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))
+ (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 (nnmaildir--grp-count group) nntp-server-buffer)
(insert " ")
(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--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)
(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))
(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)
(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))
(defun nnmaildir-request-delete-group (gname force &optional server)
(let ((group (nnmaildir--prepare server gname))
- pgname grp-dir dir ls deactivate-mark)
+ pgname grp-dir target dir ls deactivate-mark)
(catch 'return
(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--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}"))
(delete-directory (nnmaildir--marks-dir dir))
(delete-directory dir)
- (setq grp-dir (directory-file-name grp-dir)
- dir (car (file-attributes grp-dir)))
- (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)
+ (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)
(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
(throw 'return nil))
(save-excursion
(set-buffer buffer)
- (write-region (point-min) (point-max) tmpfile nil 'no-message nil
- 'excl))
+ (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 suffix result nnmaildir--file deactivate-mark)
(catch 'return
(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 article)
+ srv-dir dir file time tmpfile curfile 24h article)
(catch 'return
(unless group
(setf (nnmaildir--srv-error nnmaildir--cur-server)
(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))
+ 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))
- (unless (zerop nnmaildir--delivery-ct)
- (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)
(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)
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
- 'excl)
+ (gmm-write-region (point-min) (point-max) tmpfile nil 'no-message nil
+ 'excl)
(unix-sync))) ;; no fsync :(
- (cancel-timer 24h)
+ (nnheader-cancel-timer 24h)
(condition-case err
(add-name-to-file tmpfile curfile)
(error
(not (string-equal target pgname))) ;; Move it.
(erase-buffer)
(nnheader-insert-file-contents nnmaildir--file)
- (gnus-request-accept-article target nil nil 'no-encode))
+ (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))
(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 markfile nlist
- ranges begin end article all-marks todo-marks did-marks mdir mfile
- pgname ls markfilenew deactivate-mark)
+ 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))
(mapcar
(lambda (mark)
(setq mdir (nnmaildir--subdir marksdir (symbol-name mark))
+ permarkfile (concat mdir ":")
mfile (concat mdir (nnmaildir--art-prefix article)))
- (unless (memq mark did-marks)
- (nnmaildir--mkdir mdir)
- (setq did-marks (cons mark did-marks)))
- (unless (file-exists-p mfile)
- (condition-case nil
- (add-name-to-file markfile mfile)
- (file-error
- (unless (file-exists-p mfile)
- ;; 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))))))
+ (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)
(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)
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)
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)
+ (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)
+ (t 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 (intern-soft file flist)
- (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