X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;ds=sidebyside;f=elmo%2Felmo-maildir.el;h=fd41839afa8970b7a7f64e7822a1e1e45eba7543;hb=57f081e684a5f0a1de02c96bc61ec175784974bb;hp=8f61227f3400ea1913ff820d504e84c764ad0fb4;hpb=bd1c7daca8de303dd5766cb7831e964cfe3a03c5;p=elisp%2Fwanderlust.git

diff --git a/elmo/elmo-maildir.el b/elmo/elmo-maildir.el
index 8f61227..fd41839 100644
--- a/elmo/elmo-maildir.el
+++ b/elmo/elmo-maildir.el
@@ -40,6 +40,11 @@
   :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
@@ -92,30 +97,24 @@ LOCATION."
 	 (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))
@@ -132,128 +131,99 @@ 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-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
@@ -336,31 +306,25 @@ LOCATION."
      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)
@@ -429,7 +393,7 @@ file name for maildir directories."
     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)
@@ -442,11 +406,15 @@ file name for maildir directories."
 	  (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))))
@@ -485,23 +453,18 @@ file name for maildir directories."
   (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)))
+	    (table (elmo-folder-flag-table folder))
 	    (succeeds numbers)
-	    filename mark flag id)
+	    filename flags id)
 	(dolist (number numbers)
-	  (setq mark (and src-msgdb-exists
-			  (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))
@@ -510,10 +473,10 @@ file name for maildir directories."
 	  (when (setq id (and src-msgdb-exists
 			      (elmo-message-field src-folder (car numbers)
 						  'message-id)))
-	    (elmo-flag-table-set table id flag))
+	    (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)))
 
@@ -525,7 +488,8 @@ 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