:type 'directory
:group 'elmo)
+(defconst elmo-maildir-flag-specs '((important ?F)
+ (read ?S)
+ (unread ?S 'remove)
+ (answered ?R)))
+
;;; ELMO Maildir folder
(eval-and-compile
(luna-define-class elmo-maildir-folder
(cur (directory-files cur-dir
nil "^[^.].*$" t))
unread-locations flagged-locations answered-locations
- seen flagged answered sym locations)
+ sym locations flag-list)
(setq locations
(mapcar
(lambda (x)
(if (string-match "^\\([^:]+\\):\\([^:]+\\)$" x)
(progn
- (setq seen nil answered nil flagged nil)
- (save-match-data
- (cond
- ((string-match "F" (elmo-match-string 2 x))
- (setq flagged t))
- ((string-match "R" (elmo-match-string 2 x))
- (setq answered t))
- ((string-match "S" (elmo-match-string 2 x))
- (setq seen t))))
- (setq sym (elmo-match-string 1 x))
- (cond
- (flagged (setq flagged-locations
- (cons sym flagged-locations)))
- (answered (setq answered-locations
- (cons sym answered-locations)))
- (seen)
- (t
- (setq unread-locations (cons sym unread-locations))))
+ (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))
cur))
(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-folder-msgdb-create
- ((folder elmo-maildir-folder) numbers flag-table)
+(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)
- overview number-alist mark-alist entity message-id flag
- file location pair mark cache-status file-flag)
+ entity message-id flags location)
(message "Creating msgdb...")
(dolist (number numbers)
(setq location (elmo-map-message-location folder number))
(setq entity
- (elmo-msgdb-create-overview-entity-from-file
+ (elmo-msgdb-create-message-entity-from-file
+ (elmo-msgdb-message-entity-handler new-msgdb)
number
- (setq file
- (elmo-maildir-message-file-name folder location))))
+ (elmo-maildir-message-file-name folder location)))
(when entity
- (setq overview
- (elmo-msgdb-append-element overview entity)
- number-alist
- (elmo-msgdb-number-add number-alist
- (elmo-message-entity-number entity)
- (setq message-id
- (elmo-message-entity-field
- entity 'message-id)))
+ (setq message-id (elmo-message-entity-field entity 'message-id)
;; Precede flag-table to file-info.
- flag (elmo-flag-table-get flag-table message-id)
- file-flag nil
- mark nil)
- (setq cache-status
- (elmo-file-cache-status (elmo-file-cache-get message-id)))
-
+ flags (copy-sequence
+ (elmo-flag-table-get flag-table message-id)))
+
;; Already flagged on filename (precede it to flag-table).
- (cond
- ((member location flagged-list)
- (setq file-flag 'important
- mark elmo-msgdb-important-mark))
- ((member location answered-list)
- (setq file-flag 'answered
- mark (elmo-msgdb-mark 'answered cache-status)))
- ((member location unread-list)
- (setq file-flag 'unread
- mark (elmo-msgdb-mark 'unread cache-status)))
- (t (setq file-flag 'read)))
-
- ;; Set mark according to flag-table if file status is unread or read.
- (when (or (eq file-flag 'read)
- (eq file-flag 'unread))
- ;;
- (unless (eq 'read flag)
- (setq mark (elmo-msgdb-mark flag cache-status 'new)))
- ;; Update filename's info portion according to the flag-table.
- (cond
- ((and (or (eq flag 'important)
- (setq mark (elmo-msgdb-global-mark-get
- (elmo-message-entity-field
- entity 'message-id))))
- (not (eq file-flag 'important)))
- (elmo-maildir-set-mark file ?F)
- ;; Delete from unread location list.
- (elmo-maildir-folder-set-unread-locations-internal
- folder
- (delete location
- (elmo-maildir-folder-unread-locations-internal
- folder)))
- ;; Append to flagged location list.
- (elmo-maildir-folder-set-flagged-locations-internal
- folder
- (cons location
- (elmo-maildir-folder-flagged-locations-internal
+ (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))))
- ((and (eq flag 'answered)
- (not (eq file-flag 'answered)))
- (elmo-maildir-set-mark file ?R)
- ;; Delete from unread locations.
- (elmo-maildir-folder-set-unread-locations-internal
- folder
- (delete location
- (elmo-maildir-folder-unread-locations-internal folder)))
- ;; Append to answered location list.
- (elmo-maildir-folder-set-answered-locations-internal
- folder
- (cons location
- (elmo-maildir-folder-answered-locations-internal folder))))
- ((and (eq flag 'read)
- (not (eq file-flag 'read)))
- (elmo-maildir-set-mark file ?S)
- ;; Delete from unread locations.
- (elmo-maildir-folder-set-unread-locations-internal
- folder
- (delete location
- (elmo-maildir-folder-unread-locations-internal
- folder))))))
- (if mark
- (setq mark-alist
- (elmo-msgdb-mark-append
- mark-alist
- (elmo-msgdb-overview-entity-get-number
- entity)
- mark)))
+ (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
- (list overview number-alist mark-alist))))
+ (elmo-msgdb-sort-by-date new-msgdb)))
(defun elmo-maildir-cleanup-temporal (dir)
;; Delete files in the tmp dir which are not accessed
mark))
t)
-(luna-define-method elmo-map-folder-mark-as-important ((folder elmo-maildir-folder)
- locs)
- (elmo-maildir-set-mark-msgs folder locs ?F))
-
-(luna-define-method elmo-map-folder-unmark-important ((folder elmo-maildir-folder)
- locs)
- (elmo-maildir-delete-mark-msgs folder locs ?F))
-
-(luna-define-method elmo-map-folder-mark-as-read ((folder elmo-maildir-folder)
- locs)
- (elmo-maildir-set-mark-msgs folder locs ?S))
-
-(luna-define-method elmo-map-folder-unmark-read ((folder elmo-maildir-folder)
- locs)
- (elmo-maildir-delete-mark-msgs folder locs ?S))
-
-(luna-define-method elmo-map-folder-mark-as-answered ((folder
- elmo-maildir-folder)
- locs)
- (elmo-maildir-set-mark-msgs folder locs ?R))
-
-(luna-define-method elmo-map-folder-unmark-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)
filename))
(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)
(as-binary-output-file
(write-region (point-min) (point-max) filename nil 'no-msg))
;; add link from new.
- (elmo-add-name-to-file
+ ;; Some filesystem (like AFS) does not have hard-link.
+ ;; So we use elmo-copy-file instead of elmo-add-name-to-file here.
+ (elmo-copy-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))))
((folder elmo-maildir-folder)
src-folder numbers &optional same-number)
(if (elmo-folder-message-file-p src-folder)
- (let ((dir (elmo-maildir-folder-directory-internal folder))
- (table (elmo-flag-table-load (elmo-folder-msgdb-path 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 mark flag id)
+ filename flags id)
(dolist (number numbers)
- (setq mark (elmo-message-mark src-folder (car numbers))
- flag (cond
- ((null mark) 'read)
- ((member mark (elmo-msgdb-answered-marks))
- 'answered)
- ((not (member mark (elmo-msgdb-unread-marks)))
- 'read))
+ (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
+ ;; Some filesystem (like AFS) does not have hard-link.
+ ;; So we use elmo-copy-file instead of elmo-add-name-to-file here.
+ (elmo-copy-file
filename
(expand-file-name
(concat "new/" (file-name-nondirectory filename))
dir))
;; src folder's msgdb is loaded.
- (when (setq id (elmo-message-field src-folder (car numbers)
- 'message-id))
- (elmo-flag-table-set table id flag))
+ (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))
+ (elmo-folder-close-flag-table folder))
succeeds)
(luna-call-next-method)))
(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
(file-directory-p (expand-file-name "cur" basedir))
(file-directory-p (expand-file-name "tmp" basedir)))))
-(luna-define-method elmo-folder-diff ((folder elmo-maildir-folder)
- &optional numbers)
+(luna-define-method elmo-folder-diff ((folder elmo-maildir-folder))
(let* ((dir (elmo-maildir-folder-directory-internal folder))
(new-len (length (car (elmo-maildir-list-location dir "new"))))
(cur-len (length (car (elmo-maildir-list-location dir "cur")))))
projects / elisp / wanderlust.git / blobdiff