: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))
(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)))
(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
(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."
(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)
(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)
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)
(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
(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)
(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))))
&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)
(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)))
projects / elisp / wanderlust.git / blobdiff