X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fnnmaildir.el;h=65bb5bdb4426e46db5c503efc3acba27ce96a8c9;hb=refs%2Ftags%2Ft-gnus-6_15_24-00;hp=641ebcbacd8e6596083e51abff4385810d935321;hpb=ede88a05dcfa43327283432647c47e732f032a15;p=elisp%2Fgnus.git- diff --git a/lisp/nnmaildir.el b/lisp/nnmaildir.el index 641ebcb..65bb5bd 100644 --- a/lisp/nnmaildir.el +++ b/lisp/nnmaildir.el @@ -41,16 +41,10 @@ ;; copying, restoring, etc. ;; ;; Todo: -;; * Merge the information from -;; into the Gnus manual. -;; * Allow create-directory = ".", and configurable prefix of maildir names, -;; stripped off to produce group names. ;; * 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 readability. +;; * Improve code readability. ;;; Code: @@ -86,8 +80,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: @@ -140,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) @@ -244,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 @@ -462,7 +457,7 @@ by nnmaildir-request-article.") (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)) @@ -550,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) @@ -608,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))) @@ -620,17 +633,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))) @@ -643,11 +652,7 @@ 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 @@ -703,7 +708,9 @@ by nnmaildir-request-article.") (when (or isnew nattr) (mapcar (lambda (file) - (rename-file (concat ndir file) (concat cdir file ":2,"))) + (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)) (setf (nnmaildir--grp-new group) nattr)) (setq cattr (nth 5 (file-attributes cdir))) @@ -751,7 +758,7 @@ by nnmaildir-request-article.") files (sort files 'nnmaildir--sort-files)) (mapcar (lambda (file) - (setq file (if (consp file) file (aref file 5)) + (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) @@ -768,12 +775,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) @@ -790,6 +799,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 @@ -857,9 +875,9 @@ by nnmaildir-request-article.") (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) @@ -876,6 +894,13 @@ by nnmaildir-request-article.") 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) @@ -893,13 +918,7 @@ by nnmaildir-request-article.") (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) @@ -918,7 +937,7 @@ by nnmaildir-request-article.") (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) + (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))) @@ -949,7 +968,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) @@ -970,18 +989,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) @@ -1039,20 +1059,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)) @@ -1071,14 +1099,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) @@ -1273,7 +1303,7 @@ by nnmaildir-request-article.") (buffer-file-coding-system nil) (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) @@ -1287,15 +1317,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)) + 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) @@ -1306,7 +1338,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) @@ -1463,7 +1495,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)) @@ -1475,20 +1507,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) @@ -1509,7 +1540,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) @@ -1566,7 +1596,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))