X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=elmo%2Felmo-maildir.el;h=2c29937c3808a0215e55c5499fc4bb77b5fec843;hb=13ea09ab66b44b1a3b0971e1a24ce0da47a6ca0a;hp=abaaf3cfb992d60d392ea02c2458ddb14a5c5d54;hpb=e8d1478c4ac76dc9acd295a6c752165e033f8d1c;p=elisp%2Fwanderlust.git diff --git a/elmo/elmo-maildir.el b/elmo/elmo-maildir.el index abaaf3c..2c29937 100644 --- a/elmo/elmo-maildir.el +++ b/elmo/elmo-maildir.el @@ -40,10 +40,31 @@ :type 'directory :group 'elmo) +(defconst elmo-maildir-flag-specs '((important ?F) + (read ?S) + (unread ?S 'remove) + (answered ?R))) + +(defcustom elmo-maildir-separator + (if (memq system-type + '(windows-nt OS/2 emx ms-dos win32 w32 mswindows cygwin)) + ?\- ?:) + "Character separating the id section from the flags section. +According to the maildir specification, this should be a colon (?:), +but some file systems don't support colons in filenames." + :type 'character + :group 'elmo) + +(defmacro elmo-maildir-adjust-separator (string) + `(if (= elmo-maildir-separator ?:) + ,string + (elmo-replace-in-string + ,string ":" (char-to-string elmo-maildir-separator)))) + ;;; ELMO Maildir folder (eval-and-compile (luna-define-class elmo-maildir-folder - (elmo-map-folder) + (elmo-map-folder elmo-file-tag) (directory unread-locations flagged-locations answered-locations)) @@ -89,29 +110,44 @@ LOCATION." (defsubst elmo-maildir-list-location (dir &optional child-dir) (let* ((cur-dir (expand-file-name (or child-dir "cur") dir)) - (cur (directory-files cur-dir - nil "^[^.].*$" t)) + (cur (mapcar (lambda (x) + (cons x (elmo-get-last-modification-time + (expand-file-name x cur-dir)))) + (directory-files cur-dir + nil "^[^.].*$" t))) + (regexp (elmo-maildir-adjust-separator "^\\(.+\\):[12],\\(.*\\)$")) unread-locations flagged-locations answered-locations - sym locations flag-list) + sym locations flag-list x-time y-time) + (setq cur (sort cur + (lambda (x y) + (setq x-time (cdr x) + y-time (cdr y)) + (cond + ((< x-time y-time) + t) + ((eq x-time y-time) + (< (elmo-maildir-sequence-number (car x)) + (elmo-maildir-sequence-number (car y)))))))) (setq locations (mapcar (lambda (x) - (if (string-match "^\\([^:]+\\):\\([^:]+\\)$" x) - (progn - (setq sym (elmo-match-string 1 x) - flag-list (string-to-char-list - (elmo-match-string 2 x))) - (when (memq ?F flag-list) - (setq flagged-locations - (cons sym flagged-locations))) - (when (memq ?R flag-list) - (setq answered-locations - (cons sym answered-locations))) - (unless (memq ?S flag-list) - (setq unread-locations - (cons sym unread-locations))) - sym) - x)) + (let ((name (car x))) + (if (string-match regexp name) + (progn + (setq sym (elmo-match-string 1 name) + flag-list (string-to-char-list + (elmo-match-string 2 name))) + (when (memq ?F flag-list) + (setq flagged-locations + (cons sym flagged-locations))) + (when (memq ?R flag-list) + (setq answered-locations + (cons sym answered-locations))) + (unless (memq ?S flag-list) + (setq unread-locations + (cons sym unread-locations))) + sym) + name))) cur)) (list locations unread-locations flagged-locations answered-locations))) @@ -126,99 +162,93 @@ LOCATION." (elmo-maildir-folder-set-answered-locations-internal folder (nth 3 locs)) (nth 0 locs))) -(luna-define-method elmo-map-folder-list-unreads - ((folder elmo-maildir-folder)) - (elmo-maildir-folder-unread-locations-internal folder)) - -(luna-define-method elmo-map-folder-list-importants - ((folder elmo-maildir-folder)) - (elmo-maildir-folder-flagged-locations-internal folder)) - -(luna-define-method elmo-map-folder-list-answereds - ((folder elmo-maildir-folder)) - (elmo-maildir-folder-answered-locations-internal folder)) +(luna-define-method elmo-map-folder-list-flagged ((folder elmo-maildir-folder) + flag) + (case flag + (unread + (elmo-maildir-folder-unread-locations-internal folder)) + (important + (elmo-maildir-folder-flagged-locations-internal folder)) + (answered + (elmo-maildir-folder-answered-locations-internal folder)) + (otherwise + t))) (luna-define-method elmo-folder-msgdb-create ((folder elmo-maildir-folder) numbers flag-table) - (let* ((unread-list (elmo-maildir-folder-unread-locations-internal folder)) - (flagged-list (elmo-maildir-folder-flagged-locations-internal folder)) - (answered-list (elmo-maildir-folder-answered-locations-internal - folder)) - (len (length numbers)) - (new-msgdb (elmo-make-msgdb)) - (i 0) - entity message-id flags location) - (message "Creating msgdb...") - (dolist (number numbers) - (setq location (elmo-map-message-location folder number)) - (setq entity - (elmo-msgdb-create-message-entity-from-file - (elmo-msgdb-message-entity-handler new-msgdb) - number - (elmo-maildir-message-file-name folder location))) - (when entity - (setq message-id (elmo-message-entity-field entity 'message-id) - ;; Precede flag-table to file-info. - flags (copy-sequence - (elmo-flag-table-get flag-table message-id))) - - ;; Already flagged on filename (precede it to flag-table). - (when (member location flagged-list) - (or (memq 'important flags) - (setq flags (cons 'important flags)))) - (when (member location answered-list) - (or (memq 'answered flags) - (setq flags (cons 'answered flags)))) - (unless (member location unread-list) - (and (memq 'unread flags) - (setq flags (delq 'unread flags)))) - - ;; Update filename's info portion according to the flag-table. - (when (and (memq 'important flags) - (not (member location flagged-list))) - (elmo-maildir-set-mark - (elmo-maildir-message-file-name folder location) - ?F) - ;; Append to flagged location list. - (elmo-maildir-folder-set-flagged-locations-internal - folder - (cons location - (elmo-maildir-folder-flagged-locations-internal - folder))) - (setq flags (delq 'unread flags))) - (when (and (memq 'answered flags) - (not (member location answered-list))) - (elmo-maildir-set-mark - (elmo-maildir-message-file-name folder location) - ?R) - ;; Append to answered location list. - (elmo-maildir-folder-set-answered-locations-internal - folder - (cons location - (elmo-maildir-folder-answered-locations-internal folder))) - (setq flags (delq 'unread flags))) - (when (and (not (memq 'unread flags)) - (member location unread-list)) - (elmo-maildir-set-mark - (elmo-maildir-message-file-name folder location) - ?S) - ;; Delete from unread locations. - (elmo-maildir-folder-set-unread-locations-internal - folder - (delete location - (elmo-maildir-folder-unread-locations-internal - folder)))) - (unless (memq 'unread flags) - (setq flags (delq 'new flags))) - (elmo-global-flags-set flags folder number message-id) - (elmo-msgdb-append-entity new-msgdb entity flags) - (when (> len elmo-display-progress-threshold) - (setq i (1+ i)) - (elmo-display-progress - 'elmo-maildir-msgdb-create "Creating msgdb..." - (/ (* i 100) len))))) - (message "Creating msgdb...done") - (elmo-msgdb-sort-by-date new-msgdb))) + (let ((unread-list (elmo-maildir-folder-unread-locations-internal folder)) + (flagged-list (elmo-maildir-folder-flagged-locations-internal folder)) + (answered-list (elmo-maildir-folder-answered-locations-internal + folder)) + (new-msgdb (elmo-make-msgdb)) + entity message-id flags location) + (elmo-with-progress-display (elmo-folder-msgdb-create (length numbers)) + "Creating msgdb" + (dolist (number numbers) + (setq location (elmo-map-message-location folder number)) + (setq entity + (elmo-msgdb-create-message-entity-from-file + (elmo-msgdb-message-entity-handler new-msgdb) + number + (elmo-maildir-message-file-name folder location))) + (when entity + (setq message-id (elmo-message-entity-field entity 'message-id) + ;; Precede flag-table to file-info. + flags (copy-sequence + (elmo-flag-table-get flag-table message-id))) + + ;; Already flagged on filename (precede it to flag-table). + (when (member location flagged-list) + (or (memq 'important flags) + (setq flags (cons 'important flags)))) + (when (member location answered-list) + (or (memq 'answered flags) + (setq flags (cons 'answered flags)))) + (unless (member location unread-list) + (and (memq 'unread flags) + (setq flags (delq 'unread flags)))) + + ;; Update filename's info portion according to the flag-table. + (when (and (memq 'important flags) + (not (member location flagged-list))) + (elmo-maildir-set-mark + (elmo-maildir-message-file-name folder location) + ?F) + ;; Append to flagged location list. + (elmo-maildir-folder-set-flagged-locations-internal + folder + (cons location + (elmo-maildir-folder-flagged-locations-internal + folder))) + (setq flags (delq 'unread flags))) + (when (and (memq 'answered flags) + (not (member location answered-list))) + (elmo-maildir-set-mark + (elmo-maildir-message-file-name folder location) + ?R) + ;; Append to answered location list. + (elmo-maildir-folder-set-answered-locations-internal + folder + (cons location + (elmo-maildir-folder-answered-locations-internal folder))) + (setq flags (delq 'unread flags))) + (when (and (not (memq 'unread flags)) + (member location unread-list)) + (elmo-maildir-set-mark + (elmo-maildir-message-file-name folder location) + ?S) + ;; Delete from unread locations. + (elmo-maildir-folder-set-unread-locations-internal + folder + (delete location + (elmo-maildir-folder-unread-locations-internal + folder)))) + (unless (memq 'unread flags) + (setq flags (delq 'new flags))) + (elmo-global-flags-set flags folder number message-id) + (elmo-msgdb-append-entity new-msgdb entity flags)) + (elmo-progress-notify 'elmo-folder-msgdb-create))) + new-msgdb)) (defun elmo-maildir-cleanup-temporal (dir) ;; Delete files in the tmp dir which are not accessed @@ -226,19 +256,19 @@ LOCATION." (let ((cur-time (current-time)) (count 0) last-accessed) - (mapcar (function - (lambda (file) - (setq last-accessed (nth 4 (file-attributes file))) - (when (or (> (- (car cur-time)(car last-accessed)) 1) - (and (eq (- (car cur-time)(car last-accessed)) 1) - (> (- (cadr cur-time)(cadr last-accessed)) - 64064))) ; 36 hours. - (message "Maildir: %d tmp file(s) are cleared." - (setq count (1+ count))) - (delete-file file)))) - (directory-files (expand-file-name "tmp" dir) - t ; full - "^[^.].*$" t)))) + (mapcar + (lambda (file) + (setq last-accessed (nth 4 (file-attributes file))) + (when (or (> (- (car cur-time)(car last-accessed)) 1) + (and (eq (- (car cur-time)(car last-accessed)) 1) + (> (- (cadr cur-time)(cadr last-accessed)) + 64064))) ; 36 hours. + (message "Maildir: %d tmp file(s) are cleared." + (setq count (1+ count))) + (delete-file file))) + (directory-files (expand-file-name "tmp" dir) + t ; full + "^[^.].*$" t)))) (defun elmo-maildir-update-current (folder) "Move all new msgs to cur in the maildir." @@ -255,14 +285,18 @@ LOCATION." (expand-file-name (car news) (expand-file-name "new" maildir)) (expand-file-name (concat (car news) - (unless (string-match ":2,[A-Z]*$" (car news)) - ":2,")) + (unless (string-match + (elmo-maildir-adjust-separator ":2,[A-Z]*$") + (car news)) + (elmo-maildir-adjust-separator ":2,"))) (expand-file-name "cur" maildir))) (setq news (cdr news))))) (defun elmo-maildir-set-mark (filename mark) "Mark the FILENAME file in the maildir. MARK is a character." - (if (string-match "^\\([^:]+:[12],\\)\\(.*\\)$" filename) + (if (string-match + (elmo-maildir-adjust-separator "^\\(.+:[12],\\)\\(.*\\)$") + filename) (let ((flaglist (string-to-char-list (elmo-match-string 2 filename)))) (unless (memq mark flaglist) @@ -272,12 +306,15 @@ LOCATION." (char-list-to-string flaglist))))) ;; Rescue no info file in maildir. (rename-file filename - (concat filename ":2," (char-to-string mark)))) + (concat filename + (elmo-maildir-adjust-separator ":2,") + (char-to-string mark)))) t) (defun elmo-maildir-delete-mark (filename mark) "Mark the FILENAME file in the maildir. MARK is a character." - (if (string-match "^\\([^:]+:2,\\)\\(.*\\)$" filename) + (if (string-match (elmo-maildir-adjust-separator "^\\(.+:2,\\)\\(.*\\)$") + filename) (let ((flaglist (string-to-char-list (elmo-match-string 2 filename)))) (when (memq mark flaglist) @@ -301,31 +338,25 @@ LOCATION." mark)) t) -(luna-define-method elmo-map-folder-flag-as-important ((folder elmo-maildir-folder) - locs) - (elmo-maildir-set-mark-msgs folder locs ?F)) - -(luna-define-method elmo-map-folder-unflag-important ((folder elmo-maildir-folder) - locs) - (elmo-maildir-delete-mark-msgs folder locs ?F)) - -(luna-define-method elmo-map-folder-flag-as-read ((folder elmo-maildir-folder) - locs) - (elmo-maildir-set-mark-msgs folder locs ?S)) - -(luna-define-method elmo-map-folder-unflag-read ((folder elmo-maildir-folder) - locs) - (elmo-maildir-delete-mark-msgs folder locs ?S)) - -(luna-define-method elmo-map-folder-flag-as-answered ((folder - elmo-maildir-folder) - locs) - (elmo-maildir-set-mark-msgs folder locs ?R)) - -(luna-define-method elmo-map-folder-unflag-answered ((folder - elmo-maildir-folder) - locs) - (elmo-maildir-delete-mark-msgs folder locs ?R)) +(defsubst elmo-maildir-set-mark-messages (folder locations mark remove) + (when mark + (if remove + (elmo-maildir-delete-mark-msgs folder locations mark) + (elmo-maildir-set-mark-msgs folder locations mark)))) + +(luna-define-method elmo-map-folder-set-flag ((folder elmo-maildir-folder) + locations flag) + (let ((spec (cdr (assq flag elmo-maildir-flag-specs)))) + (when spec + (elmo-maildir-set-mark-messages folder locations + (car spec) (nth 1 spec))))) + +(luna-define-method elmo-map-folder-unset-flag ((folder elmo-maildir-folder) + locations flag) + (let ((spec (cdr (assq flag elmo-maildir-flag-specs)))) + (when spec + (elmo-maildir-set-mark-messages folder locations + (car spec) (not (nth 1 spec)))))) (luna-define-method elmo-folder-list-subfolders ((folder elmo-maildir-folder) &optional one-level) @@ -347,36 +378,24 @@ LOCATION." (defvar elmo-maildir-sequence-number-internal 0) -(static-cond - ((>= emacs-major-version 19) - (defun elmo-maildir-make-unique-string () - "This function generates a string that can be used as a unique -file name for maildir directories." - (let ((cur-time (current-time))) - (format "%.0f.%d_%d.%s" - (+ (* (car cur-time) - (float 65536)) (cadr cur-time)) - (emacs-pid) - (incf elmo-maildir-sequence-number-internal) - (system-name))))) - ((eq emacs-major-version 18) - ;; A fake function for v18 - (defun elmo-maildir-make-unique-string () - "This function generates a string that can be used as a unique +(defun elmo-maildir-sequence-number (file) + "Get `elmo-maildir' specific sequence number from FILE. +Not that FILE is the name without directory." + ;; elmo-maildir specific. + (if (string-match "^.*_\\([0-9]+\\)\\..*" file) + (string-to-number (match-string 1 file)) + -1)) + +(defun elmo-maildir-make-unique-string () + "This function generates a string that can be used as a unique file name for maildir directories." - (unless (fboundp 'float-to-string) - (load-library "float")) - (let ((time (current-time))) - (format "%s%d.%d.%s" - (substring - (float-to-string - (f+ (f* (f (car time)) - (f 65536)) - (f (cadr time)))) - 0 5) - (cadr time) - (% (abs (random t)) 10000); dummy pid - (system-name)))))) + (let ((cur-time (current-time))) + (format "%.0f.%d_%d.%s" + (+ (* (car cur-time) + (float 65536)) (cadr cur-time)) + (emacs-pid) + (incf elmo-maildir-sequence-number-internal) + (system-name)))) (defun elmo-maildir-temporal-filename (basedir) (let ((filename (expand-file-name @@ -386,15 +405,32 @@ file name for maildir directories." (make-directory (file-name-directory filename))) (while (file-exists-p filename) ;;; I don't want to wait. -;;; (sleep-for 2) +;;; (sleep-for 2) (setq filename (expand-file-name (concat "tmp/" (elmo-maildir-make-unique-string)) basedir))) filename)) +(defun elmo-maildir-move-file (src dst) + (or (condition-case nil + (progn + ;; 1. Try add-link-to-file, then delete the original. + ;; This is safe on NFS. + (add-name-to-file src dst) + (ignore-errors + ;; It's ok if the delete-file fails; + ;; elmo-maildir-cleanup-temporal will catch it later. + (delete-file src)) + t) + (error)) + ;; 2. Even on systems with hardlinks, some filesystems (like AFS) + ;; might not support them, so fall back on rename-file. This is + ;; our best shot at atomic when add-name-to-file fails. + (rename-file src dst))) + (luna-define-method elmo-folder-append-buffer ((folder elmo-maildir-folder) - &optional status number) + &optional flags number) (let ((basedir (elmo-maildir-folder-directory-internal folder)) (src-buf (current-buffer)) dst-buf filename) @@ -406,12 +442,13 @@ file name for maildir directories." (copy-to-buffer dst-buf (point-min) (point-max))) (as-binary-output-file (write-region (point-min) (point-max) filename nil 'no-msg)) - ;; add link from new. - (elmo-add-name-to-file + (elmo-maildir-move-file filename (expand-file-name (concat "new/" (file-name-nondirectory filename)) basedir)) + (elmo-folder-preserve-flags + folder (elmo-msgdb-get-message-id-from-buffer) flags) t) ;; If an error occured, return nil. (error)))) @@ -435,45 +472,45 @@ file name for maildir directories." &optional start-number) (let ((temp-dir (elmo-folder-make-temporary-directory folder)) - (cur-number (if start-number 0))) + (cur-number (or start-number 0))) (dolist (number numbers) (elmo-copy-file (elmo-message-file-name folder number) (expand-file-name - (int-to-string (if start-number (incf cur-number) number)) - temp-dir))) + (number-to-string (if start-number cur-number number)) + temp-dir)) + (incf cur-number)) temp-dir)) -(luna-define-method elmo-folder-append-messages :around - ((folder elmo-maildir-folder) - src-folder numbers &optional same-number) - (if (elmo-folder-message-file-p src-folder) - (let ((src-msgdb-exists (not (zerop (elmo-folder-length src-folder)))) - (dir (elmo-maildir-folder-directory-internal folder)) - (table (elmo-flag-table-load (elmo-folder-msgdb-path folder))) - (succeeds numbers) - filename flags id) - (dolist (number numbers) - (setq flags (elmo-message-flags src-folder (car numbers)) - filename (elmo-maildir-temporal-filename dir)) - (elmo-copy-file - (elmo-message-file-name src-folder number) - filename) - (elmo-add-name-to-file - filename - (expand-file-name - (concat "new/" (file-name-nondirectory filename)) - dir)) - ;; src folder's msgdb is loaded. - (when (setq id (and src-msgdb-exists - (elmo-message-field src-folder (car numbers) - 'message-id))) - (elmo-flag-table-set table id flags)) - (elmo-progress-notify 'elmo-folder-move-messages)) - (when (elmo-folder-persistent-p folder) - (elmo-flag-table-save (elmo-folder-msgdb-path folder) table)) - succeeds) - (luna-call-next-method))) +(defun elmo-folder-append-messages-*-maildir (folder + src-folder + numbers + same-number) + (let ((src-msgdb-exists (not (zerop (elmo-folder-length src-folder)))) + (dir (elmo-maildir-folder-directory-internal folder)) + (table (elmo-folder-flag-table folder)) + (succeeds numbers) + filename flags id) + (dolist (number numbers) + (setq flags (elmo-message-flags src-folder number) + filename (elmo-maildir-temporal-filename dir)) + (elmo-copy-file + (elmo-message-file-name src-folder number) + filename) + (elmo-maildir-move-file + filename + (expand-file-name + (concat "new/" (file-name-nondirectory filename)) + dir)) + ;; src folder's msgdb is loaded. + (when (setq id (and src-msgdb-exists + (elmo-message-field src-folder number + 'message-id))) + (elmo-flag-table-set table id flags)) + (elmo-progress-notify 'elmo-folder-move-messages)) + (when (elmo-folder-persistent-p folder) + (elmo-folder-close-flag-table folder)) + succeeds)) (luna-define-method elmo-map-folder-delete-messages ((folder elmo-maildir-folder) locations) @@ -483,14 +520,18 @@ file name for maildir directories." (if (and file (file-writable-p file) (not (file-directory-p file))) - (delete-file file))))) + (delete-file file)))) + t) (luna-define-method elmo-map-message-fetch ((folder elmo-maildir-folder) location strategy &optional section unseen) (let ((file (elmo-maildir-message-file-name folder location))) (when (file-exists-p file) - (insert-file-contents-as-binary file)))) + (insert-file-contents-as-raw-text file) + (unless unseen + (elmo-map-folder-set-flag folder (list location) 'read)) + t))) (luna-define-method elmo-folder-exists-p ((folder elmo-maildir-folder)) (let ((basedir (elmo-maildir-folder-directory-internal folder)))