X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fnnmaildir.el;h=5391192446703c62dcea3cad61a2aba8e479a220;hb=c5f7362aa49943397fec729fdcfca40679946ec8;hp=18c6eb110bd8da05491eab5dd9410eff6611430e;hpb=ca101d0305c3ff2ecc44dade2025c974ffc7168a;p=elisp%2Fgnus.git- diff --git a/lisp/nnmaildir.el b/lisp/nnmaildir.el index 18c6eb1..5391192 100644 --- a/lisp/nnmaildir.el +++ b/lisp/nnmaildir.el @@ -41,12 +41,8 @@ ;; copying, restoring, etc. ;; ;; Todo: -;; * Replace create-directory with target-prefix, so the maildirs can be in -;; the same directory as the symlinks, starting with, e.g., ".". ;; * 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. @@ -138,17 +134,17 @@ by nnmaildir-request-article.") ; ("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) @@ -242,8 +238,9 @@ by nnmaildir-request-article.") (or (file-exists-p (file-name-as-directory dir)) (make-directory-internal (directory-file-name dir)))) (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 @@ -548,6 +545,15 @@ by nnmaildir-request-article.") (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) @@ -606,11 +612,20 @@ by nnmaildir-request-article.") (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))) @@ -758,12 +773,14 @@ by nnmaildir-request-article.") (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) @@ -780,6 +797,15 @@ by nnmaildir-request-article.") 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 @@ -940,7 +966,7 @@ by nnmaildir-request-article.") (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) @@ -961,18 +987,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) @@ -1028,20 +1055,28 @@ by nnmaildir-request-article.") (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)) @@ -1060,14 +1095,16 @@ by nnmaildir-request-article.") (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) @@ -1282,7 +1319,7 @@ by nnmaildir-request-article.") (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 "." (system-name)) ;;;; FIXME: encode / and : + file (concat file "." (nnmaildir--system-name)) tmpfile (concat (nnmaildir--tmp dir) file) curfile (concat (nnmaildir--cur dir) file ":2,")) (when (file-exists-p tmpfile) @@ -1448,7 +1485,7 @@ by nnmaildir-request-article.") (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) + pgname ls permarkfile deactivate-mark) (setq del-mark (lambda (mark) (setq mfile (nnmaildir--subdir marksdir (symbol-name mark)) @@ -1460,20 +1497,19 @@ by nnmaildir-request-article.") (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) + (setq did-marks (cons mark did-marks)) (nnmaildir--mkdir mdir) - (setq did-marks (cons mark did-marks))) + (unless (file-attributes permarkfile) + (condition-case nil + (add-name-to-file markfile permarkfile) + (file-error + ;; AFS can't make hard links in separate directories + (write-region "" nil permarkfile nil 'no-message))))) (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)))))) + (add-name-to-file permarkfile mfile))) todo-marks)) set-action (lambda (article) (funcall add-action) @@ -1494,7 +1530,6 @@ by nnmaildir-request-article.") 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) @@ -1551,7 +1586,7 @@ by nnmaildir-request-article.") dir (file-name-as-directory (car dir))) (mapcar (lambda (file) - (unless (intern-soft file flist) + (unless (or (intern-soft file flist) (string= file ":")) (setq file (concat dir file)) (delete-file file))) files))