1 ;;; elmo-maildir.el --- Maildir interface for ELMO.
3 ;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
5 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
6 ;; Keywords: mail, net news
8 ;; This file is part of ELMO (Elisp Library for Message Orchestration).
10 ;; This program is free software; you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 2, or (at your option)
15 ;; This program is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs; see the file COPYING. If not, write to the
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23 ;; Boston, MA 02111-1307, USA.
32 (eval-when-compile (require 'cl
))
38 (defcustom elmo-maildir-folder-path
"~/Maildir"
39 "*Maildir folder path."
43 (defconst elmo-maildir-flag-specs
'((important ?F
)
48 (defcustom elmo-maildir-separator
50 '(windows-nt OS
/2 emx ms-dos win32 w32 mswindows cygwin
))
52 "Character separating the id section from the flags section.
53 According to the maildir specification, this should be a colon (?:),
54 but some file systems don't support colons in filenames."
58 (defmacro elmo-maildir-adjust-separator
(string)
59 `(if (= elmo-maildir-separator ?
:)
61 (elmo-replace-in-string
62 ,string
":" (char-to-string elmo-maildir-separator
))))
64 ;;; ELMO Maildir folder
66 (luna-define-class elmo-maildir-folder
67 (elmo-map-folder elmo-file-tag
)
68 (directory unread-locations
71 (luna-define-internal-accessors 'elmo-maildir-folder
))
73 (luna-define-method elmo-folder-initialize
((folder
76 (if (file-name-absolute-p name
)
77 (elmo-maildir-folder-set-directory-internal
79 (expand-file-name name
))
80 (elmo-maildir-folder-set-directory-internal
84 elmo-maildir-folder-path
)))
87 (luna-define-method elmo-folder-expand-msgdb-path
((folder
90 (elmo-replace-string-as-filename
91 (elmo-maildir-folder-directory-internal folder
))
94 elmo-msgdb-directory
)))
96 (defun elmo-maildir-message-file-name (folder location
)
97 "Get a file name of the message from FOLDER which corresponded to
99 (let ((file (file-name-completion
103 (elmo-maildir-folder-directory-internal folder
)))))
106 (if (eq file t
) location file
)
109 (elmo-maildir-folder-directory-internal folder
))))))
111 (defsubst elmo-maildir-list-location
(dir &optional child-dir
)
112 (let* ((cur-dir (expand-file-name (or child-dir
"cur") dir
))
113 (cur (mapcar (lambda (x)
114 (cons x
(elmo-get-last-modification-time
115 (expand-file-name x cur-dir
))))
116 (directory-files cur-dir
118 (regexp (elmo-maildir-adjust-separator "^\\(.+\\):[12],\\(.*\\)$"))
119 unread-locations flagged-locations answered-locations
120 sym locations flag-list x-time y-time
)
129 (< (elmo-maildir-sequence-number (car x
))
130 (elmo-maildir-sequence-number (car y
))))))))
134 (let ((name (car x
)))
135 (if (string-match regexp name
)
137 (setq sym
(elmo-match-string 1 name
)
138 flag-list
(string-to-char-list
139 (elmo-match-string 2 name
)))
140 (when (memq ?F flag-list
)
141 (setq flagged-locations
142 (cons sym flagged-locations
)))
143 (when (memq ?R flag-list
)
144 (setq answered-locations
145 (cons sym answered-locations
)))
146 (unless (memq ?S flag-list
)
147 (setq unread-locations
148 (cons sym unread-locations
)))
152 (list locations unread-locations flagged-locations answered-locations
)))
154 (luna-define-method elmo-map-folder-list-message-locations
155 ((folder elmo-maildir-folder
))
156 (elmo-maildir-update-current folder
)
157 (let ((locs (elmo-maildir-list-location
158 (elmo-maildir-folder-directory-internal folder
))))
159 ;; 0: locations, 1: unread-locs, 2: flagged-locs 3: answered-locs
160 (elmo-maildir-folder-set-unread-locations-internal folder
(nth 1 locs
))
161 (elmo-maildir-folder-set-flagged-locations-internal folder
(nth 2 locs
))
162 (elmo-maildir-folder-set-answered-locations-internal folder
(nth 3 locs
))
165 (luna-define-method elmo-map-folder-list-flagged
((folder elmo-maildir-folder
)
169 (elmo-maildir-folder-unread-locations-internal folder
))
171 (elmo-maildir-folder-flagged-locations-internal folder
))
173 (elmo-maildir-folder-answered-locations-internal folder
))
177 (luna-define-method elmo-folder-msgdb-create
((folder elmo-maildir-folder
)
179 (let ((unread-list (elmo-maildir-folder-unread-locations-internal folder
))
180 (flagged-list (elmo-maildir-folder-flagged-locations-internal folder
))
181 (answered-list (elmo-maildir-folder-answered-locations-internal
183 (new-msgdb (elmo-make-msgdb))
184 entity message-id flags location
)
185 (elmo-with-progress-display (elmo-folder-msgdb-create (length numbers
))
187 (dolist (number numbers
)
188 (setq location
(elmo-map-message-location folder number
))
190 (elmo-msgdb-create-message-entity-from-file
191 (elmo-msgdb-message-entity-handler new-msgdb
)
193 (elmo-maildir-message-file-name folder location
)))
195 (setq message-id
(elmo-message-entity-field entity
'message-id
)
196 ;; Precede flag-table to file-info.
198 (elmo-flag-table-get flag-table message-id
)))
200 ;; Already flagged on filename (precede it to flag-table).
201 (when (member location flagged-list
)
202 (or (memq 'important flags
)
203 (setq flags
(cons 'important flags
))))
204 (when (member location answered-list
)
205 (or (memq 'answered flags
)
206 (setq flags
(cons 'answered flags
))))
207 (unless (member location unread-list
)
208 (and (memq 'unread flags
)
209 (setq flags
(delq 'unread flags
))))
211 ;; Update filename's info portion according to the flag-table.
212 (when (and (memq 'important flags
)
213 (not (member location flagged-list
)))
214 (elmo-maildir-set-mark
215 (elmo-maildir-message-file-name folder location
)
217 ;; Append to flagged location list.
218 (elmo-maildir-folder-set-flagged-locations-internal
221 (elmo-maildir-folder-flagged-locations-internal
223 (setq flags
(delq 'unread flags
)))
224 (when (and (memq 'answered flags
)
225 (not (member location answered-list
)))
226 (elmo-maildir-set-mark
227 (elmo-maildir-message-file-name folder location
)
229 ;; Append to answered location list.
230 (elmo-maildir-folder-set-answered-locations-internal
233 (elmo-maildir-folder-answered-locations-internal folder
)))
234 (setq flags
(delq 'unread flags
)))
235 (when (and (not (memq 'unread flags
))
236 (member location unread-list
))
237 (elmo-maildir-set-mark
238 (elmo-maildir-message-file-name folder location
)
240 ;; Delete from unread locations.
241 (elmo-maildir-folder-set-unread-locations-internal
244 (elmo-maildir-folder-unread-locations-internal
246 (unless (memq 'unread flags
)
247 (setq flags
(delq 'new flags
)))
248 (elmo-global-flags-set flags folder number message-id
)
249 (elmo-msgdb-append-entity new-msgdb entity flags
))
250 (elmo-progress-notify 'elmo-folder-msgdb-create
)))
253 (defun elmo-maildir-cleanup-temporal (dir)
254 ;; Delete files in the tmp dir which are not accessed
255 ;; for more than 36 hours.
256 (let ((cur-time (current-time))
261 (setq last-accessed
(nth 4 (file-attributes file
)))
262 (when (or (> (- (car cur-time
)(car last-accessed
)) 1)
263 (and (eq (- (car cur-time
)(car last-accessed
)) 1)
264 (> (- (cadr cur-time
)(cadr last-accessed
))
266 (message "Maildir: %d tmp file(s) are cleared."
267 (setq count
(1+ count
)))
268 (delete-file file
))))
269 (directory-files (expand-file-name "tmp" dir
)
273 (defun elmo-maildir-update-current (folder)
274 "Move all new msgs to cur in the maildir."
275 (let* ((maildir (elmo-maildir-folder-directory-internal folder
))
276 (news (directory-files (expand-file-name "new"
280 ;; cleanup tmp directory.
281 (elmo-maildir-cleanup-temporal maildir
)
282 ;; move new msgs to cur directory.
285 (expand-file-name (car news
) (expand-file-name "new" maildir
))
286 (expand-file-name (concat
288 (unless (string-match
289 (elmo-maildir-adjust-separator ":2,[A-Z]*$")
291 (elmo-maildir-adjust-separator ":2,")))
292 (expand-file-name "cur" maildir
)))
293 (setq news
(cdr news
)))))
295 (defun elmo-maildir-set-mark (filename mark
)
296 "Mark the FILENAME file in the maildir. MARK is a character."
298 (elmo-maildir-adjust-separator "^\\(.+:[12],\\)\\(.*\\)$")
300 (let ((flaglist (string-to-char-list (elmo-match-string
302 (unless (memq mark flaglist
)
303 (setq flaglist
(sort (cons mark flaglist
) '<))
304 (rename-file filename
305 (concat (elmo-match-string 1 filename
)
306 (char-list-to-string flaglist
)))))
307 ;; Rescue no info file in maildir.
308 (rename-file filename
310 (elmo-maildir-adjust-separator ":2,")
311 (char-to-string mark
))))
314 (defun elmo-maildir-delete-mark (filename mark
)
315 "Mark the FILENAME file in the maildir. MARK is a character."
316 (if (string-match (elmo-maildir-adjust-separator "^\\(.+:2,\\)\\(.*\\)$")
318 (let ((flaglist (string-to-char-list (elmo-match-string
320 (when (memq mark flaglist
)
321 (setq flaglist
(delq mark flaglist
))
322 (rename-file filename
323 (concat (elmo-match-string 1 filename
)
325 (char-list-to-string flaglist
))))))))
327 (defsubst elmo-maildir-set-mark-msgs
(folder locs mark
)
329 (elmo-maildir-set-mark
330 (elmo-maildir-message-file-name folder loc
)
334 (defsubst elmo-maildir-delete-mark-msgs
(folder locs mark
)
336 (elmo-maildir-delete-mark
337 (elmo-maildir-message-file-name folder loc
)
341 (defsubst elmo-maildir-set-mark-messages
(folder locations mark remove
)
344 (elmo-maildir-delete-mark-msgs folder locations mark
)
345 (elmo-maildir-set-mark-msgs folder locations mark
))))
347 (luna-define-method elmo-map-folder-set-flag
((folder elmo-maildir-folder
)
349 (let ((spec (cdr (assq flag elmo-maildir-flag-specs
))))
351 (elmo-maildir-set-mark-messages folder locations
352 (car spec
) (nth 1 spec
)))))
354 (luna-define-method elmo-map-folder-unset-flag
((folder elmo-maildir-folder
)
356 (let ((spec (cdr (assq flag elmo-maildir-flag-specs
))))
358 (elmo-maildir-set-mark-messages folder locations
359 (car spec
) (not (nth 1 spec
))))))
361 (luna-define-method elmo-folder-list-subfolders
362 ((folder elmo-maildir-folder
) &optional one-level
)
363 (let ((prefix (concat (elmo-folder-name-internal folder
)
364 (unless (string= (elmo-folder-prefix-internal folder
)
365 (elmo-folder-name-internal folder
))
367 (elmo-list-subdirectories-ignore-regexp
368 "^\\(\\.\\.?\\|cur\\|tmp\\|new\\)$")
369 elmo-have-link-count
)
371 (list (elmo-folder-name-internal folder
))
372 (elmo-mapcar-list-of-list
373 (function (lambda (x) (concat prefix x
)))
374 (elmo-list-subdirectories
375 (elmo-maildir-folder-directory-internal folder
)
379 (defvar elmo-maildir-sequence-number-internal
0)
381 (defun elmo-maildir-sequence-number (file)
382 "Get `elmo-maildir' specific sequence number from FILE.
383 Not that FILE is the name without directory."
384 ;; elmo-maildir specific.
385 (if (string-match "^.*_\\([0-9]+\\)\\..*" file
)
386 (string-to-number (match-string 1 file
))
389 (defun elmo-maildir-make-unique-string ()
390 "This function generates a string that can be used as a unique
391 file name for maildir directories."
392 (let ((cur-time (current-time)))
393 (format "%.0f.%d_%d.%s"
395 (float 65536)) (cadr cur-time
))
397 (incf elmo-maildir-sequence-number-internal
)
400 (defun elmo-maildir-temporal-filename (basedir)
401 (let ((filename (expand-file-name
402 (concat "tmp/" (elmo-maildir-make-unique-string))
404 (unless (file-exists-p (file-name-directory filename
))
405 (make-directory (file-name-directory filename
)))
406 (while (file-exists-p filename
)
407 ;;; I don't want to wait.
411 (concat "tmp/" (elmo-maildir-make-unique-string))
415 (defun elmo-maildir-move-file (src dst
)
416 (or (condition-case nil
418 ;; 1. Try add-link-to-file, then delete the original.
419 ;; This is safe on NFS.
420 (add-name-to-file src dst
)
422 ;; It's ok if the delete-file fails;
423 ;; elmo-maildir-cleanup-temporal will catch it later.
427 ;; 2. Even on systems with hardlinks, some filesystems (like AFS)
428 ;; might not support them, so fall back on rename-file. This is
429 ;; our best shot at atomic when add-name-to-file fails.
430 (rename-file src dst
)))
432 (luna-define-method elmo-folder-append-buffer
((folder elmo-maildir-folder
)
433 &optional flags number
)
434 (let ((basedir (elmo-maildir-folder-directory-internal folder
))
435 (src-buf (current-buffer))
439 (setq filename
(elmo-maildir-temporal-filename basedir
))
440 (setq dst-buf
(current-buffer))
441 (with-current-buffer src-buf
442 (copy-to-buffer dst-buf
(point-min) (point-max)))
443 (as-binary-output-file
444 (write-region (point-min) (point-max) filename nil
'no-msg
))
445 (elmo-maildir-move-file
448 (concat "new/" (file-name-nondirectory filename
))
450 (elmo-folder-preserve-flags
451 folder
(elmo-msgdb-get-message-id-from-buffer) flags
)
453 ;; If an error occured, return nil.
456 (luna-define-method elmo-folder-message-file-p
((folder elmo-maildir-folder
))
459 (luna-define-method elmo-message-file-name
((folder elmo-maildir-folder
)
461 (elmo-maildir-message-file-name
463 (elmo-map-message-location folder number
)))
465 (luna-define-method elmo-folder-message-make-temp-file-p
466 ((folder elmo-maildir-folder
))
469 (luna-define-method elmo-folder-message-make-temp-files
((folder
474 (let ((temp-dir (elmo-folder-make-temporary-directory folder
))
475 (cur-number (or start-number
0)))
476 (dolist (number numbers
)
478 (elmo-message-file-name folder number
)
480 (int-to-string (if start-number cur-number number
))
485 (defun elmo-folder-append-messages-*-maildir
(folder
489 (let ((src-msgdb-exists (not (zerop (elmo-folder-length src-folder
))))
490 (dir (elmo-maildir-folder-directory-internal folder
))
491 (table (elmo-folder-flag-table folder
))
494 (dolist (number numbers
)
495 (setq flags
(elmo-message-flags src-folder number
)
496 filename
(elmo-maildir-temporal-filename dir
))
498 (elmo-message-file-name src-folder number
)
500 (elmo-maildir-move-file
503 (concat "new/" (file-name-nondirectory filename
))
505 ;; src folder's msgdb is loaded.
506 (when (setq id
(and src-msgdb-exists
507 (elmo-message-field src-folder number
509 (elmo-flag-table-set table id flags
))
510 (elmo-progress-notify 'elmo-folder-move-messages
))
511 (when (elmo-folder-persistent-p folder
)
512 (elmo-folder-close-flag-table folder
))
515 (luna-define-method elmo-map-folder-delete-messages
516 ((folder elmo-maildir-folder
) locations
)
518 (dolist (location locations
)
519 (setq file
(elmo-maildir-message-file-name folder location
))
521 (file-writable-p file
)
522 (not (file-directory-p file
)))
523 (delete-file file
))))
526 (luna-define-method elmo-map-message-fetch
((folder elmo-maildir-folder
)
528 &optional section unseen
)
529 (let ((file (elmo-maildir-message-file-name folder location
)))
530 (when (file-exists-p file
)
531 (insert-file-contents-as-raw-text file
)
533 (elmo-map-folder-set-flag folder
(list location
) 'read
))
536 (luna-define-method elmo-folder-exists-p
((folder elmo-maildir-folder
))
537 (let ((basedir (elmo-maildir-folder-directory-internal folder
)))
538 (and (file-directory-p (expand-file-name "new" basedir
))
539 (file-directory-p (expand-file-name "cur" basedir
))
540 (file-directory-p (expand-file-name "tmp" basedir
)))))
542 (luna-define-method elmo-folder-diff
((folder elmo-maildir-folder
))
543 (let* ((dir (elmo-maildir-folder-directory-internal folder
))
544 (new-len (length (car (elmo-maildir-list-location dir
"new"))))
545 (cur-len (length (car (elmo-maildir-list-location dir
"cur")))))
546 (cons new-len
(+ new-len cur-len
))))
548 (luna-define-method elmo-folder-creatable-p
((folder elmo-maildir-folder
))
551 (luna-define-method elmo-folder-writable-p
((folder elmo-maildir-folder
))
554 (luna-define-method elmo-folder-create
((folder elmo-maildir-folder
))
555 (let ((basedir (elmo-maildir-folder-directory-internal folder
)))
558 (dolist (dir '("." "new" "cur" "tmp"))
559 (setq dir
(expand-file-name dir basedir
))
560 (or (file-directory-p dir
)
562 (elmo-make-directory dir
)
563 (set-file-modes dir
448))))
567 (luna-define-method elmo-folder-delete
((folder elmo-maildir-folder
))
568 (let ((msgs (and (elmo-folder-exists-p folder
)
569 (elmo-folder-list-messages folder
))))
570 (when (yes-or-no-p (format "%sDelete msgdb and substance of \"%s\"? "
571 (if (> (length msgs
) 0)
572 (format "%d msg(s) exists. " (length msgs
))
574 (elmo-folder-name-internal folder
)))
575 (let ((basedir (elmo-maildir-folder-directory-internal folder
)))
577 (let ((tmp-files (directory-files
578 (expand-file-name "tmp" basedir
)
580 ;; Delete files in tmp.
581 (dolist (file tmp-files
)
583 (dolist (dir '("new" "cur" "tmp" "."))
584 (setq dir
(expand-file-name dir basedir
))
585 (if (not (file-directory-p dir
))
587 (elmo-delete-directory dir t
))))
589 (elmo-msgdb-delete-path folder
)
592 (luna-define-method elmo-folder-rename-internal
((folder elmo-maildir-folder
)
594 (let* ((old (elmo-maildir-folder-directory-internal folder
))
595 (new (elmo-maildir-folder-directory-internal new-folder
))
596 (new-dir (directory-file-name (file-name-directory new
))))
597 (unless (file-directory-p old
)
598 (error "No such directory: %s" old
))
599 (when (file-exists-p new
)
600 (error "Already exists directory: %s" new
))
601 (unless (file-directory-p new-dir
)
602 (elmo-make-directory new-dir
))
603 (rename-file old new
)
607 (product-provide (provide 'elmo-maildir
) (require 'elmo-version
))
609 ;;; elmo-maildir.el ends here