X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=elmo%2Felmo-maildir.el;h=2c29937c3808a0215e55c5499fc4bb77b5fec843;hb=13ea09ab66b44b1a3b0971e1a24ce0da47a6ca0a;hp=7e2fb5622b9b32c301fcdfd832f0ed549be6e774;hpb=61878895a4897bb65aea9b6e611139d25e3e448e;p=elisp%2Fwanderlust.git diff --git a/elmo/elmo-maildir.el b/elmo/elmo-maildir.el index 7e2fb56..2c29937 100644 --- a/elmo/elmo-maildir.el +++ b/elmo/elmo-maildir.el @@ -45,9 +45,10 @@ (unread ?S 'remove) (answered ?R))) -;; Decided at compile time. (defcustom elmo-maildir-separator - (if (memq system-type '(windows-nt)) ?\- ?:) + (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." @@ -63,7 +64,7 @@ but some file systems don't support colons in filenames." ;;; 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)) @@ -109,31 +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 - (elmo-maildir-adjust-separator "^\\([^:]+\\):\\([^:]+\\)$") - 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))) @@ -162,85 +176,79 @@ LOCATION." (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 @@ -248,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." @@ -287,7 +295,7 @@ LOCATION." (defun elmo-maildir-set-mark (filename mark) "Mark the FILENAME file in the maildir. MARK is a character." (if (string-match - (elmo-maildir-adjust-separator "^\\([^:]+:[12],\\)\\(.*\\)$") + (elmo-maildir-adjust-separator "^\\(.+:[12],\\)\\(.*\\)$") filename) (let ((flaglist (string-to-char-list (elmo-match-string 2 filename)))) @@ -305,7 +313,7 @@ LOCATION." (defun elmo-maildir-delete-mark (filename mark) "Mark the FILENAME file in the maildir. MARK is a character." - (if (string-match (elmo-maildir-adjust-separator "^\\([^:]+:2,\\)\\(.*\\)$") + (if (string-match (elmo-maildir-adjust-separator "^\\(.+:2,\\)\\(.*\\)$") filename) (let ((flaglist (string-to-char-list (elmo-match-string 2 filename)))) @@ -370,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 @@ -409,7 +405,7 @@ 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)) @@ -417,23 +413,17 @@ file name for maildir directories." filename)) (defun elmo-maildir-move-file (src dst) - (or (and (fboundp 'make-symbolic-link) - ;; 1. If make-symbolic-link is defined, then assume the system has - ;; hardlinks and try add-link-to-file, then delete the original. - ;; This is safe on NFS. - (condition-case nil - (progn - (add-name-to-file src dst) - t) - (error)) - ;; It's ok if the delete-file fails; - ;; elmo-maildir-cleanup-temporal will catch it later. - (progn - (condition-case nil - (delete-file src) - (error)) - ;; Exit this function anyway. - t)) + (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. @@ -482,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-folder-flag-table 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-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 (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-folder-close-flag-table folder)) - 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) @@ -538,7 +528,7 @@ file name for maildir directories." &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)))