;; 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:
-;; * Artificially add nonexistent article to the 'read range, to fix the
-;; wrong-count problem.
-;; * Replace create-directory with target-prefix, so the maildirs can be in
-;; the same directory as the symlinks, starting with, e.g., ".".
+;; * 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.
(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)
)
]
; ("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)
+ (mapcar 'delete-file (funcall ls dir 'full "\\`[^.]" 'nosort))
+ (delete-directory dir)))
(defun nnmaildir--group-maxnum (server group)
- (if (zerop (nnmaildir--grp-count group)) 0
- (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))
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)))
(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)))
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
(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
(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)
(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)
(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))
+ (setq ranges existing)
(throw 'got-ranges nil))
(setq mtime (nth 5 (file-attributes markdir)))
(set (intern mark new-mmth) mtime)
projects / gnus / blobdiff