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
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 (len (length numbers))
184 (new-msgdb (elmo-make-msgdb))
186 entity message-id flags location)
187 (message "Creating msgdb...")
188 (dolist (number numbers)
189 (setq location (elmo-map-message-location folder number))
191 (elmo-msgdb-create-message-entity-from-file
192 (elmo-msgdb-message-entity-handler new-msgdb)
194 (elmo-maildir-message-file-name folder location)))
196 (setq message-id (elmo-message-entity-field entity 'message-id)
197 ;; Precede flag-table to file-info.
199 (elmo-flag-table-get flag-table message-id)))
201 ;; Already flagged on filename (precede it to flag-table).
202 (when (member location flagged-list)
203 (or (memq 'important flags)
204 (setq flags (cons 'important flags))))
205 (when (member location answered-list)
206 (or (memq 'answered flags)
207 (setq flags (cons 'answered flags))))
208 (unless (member location unread-list)
209 (and (memq 'unread flags)
210 (setq flags (delq 'unread flags))))
212 ;; Update filename's info portion according to the flag-table.
213 (when (and (memq 'important flags)
214 (not (member location flagged-list)))
215 (elmo-maildir-set-mark
216 (elmo-maildir-message-file-name folder location)
218 ;; Append to flagged location list.
219 (elmo-maildir-folder-set-flagged-locations-internal
222 (elmo-maildir-folder-flagged-locations-internal
224 (setq flags (delq 'unread flags)))
225 (when (and (memq 'answered flags)
226 (not (member location answered-list)))
227 (elmo-maildir-set-mark
228 (elmo-maildir-message-file-name folder location)
230 ;; Append to answered location list.
231 (elmo-maildir-folder-set-answered-locations-internal
234 (elmo-maildir-folder-answered-locations-internal folder)))
235 (setq flags (delq 'unread flags)))
236 (when (and (not (memq 'unread flags))
237 (member location unread-list))
238 (elmo-maildir-set-mark
239 (elmo-maildir-message-file-name folder location)
241 ;; Delete from unread locations.
242 (elmo-maildir-folder-set-unread-locations-internal
245 (elmo-maildir-folder-unread-locations-internal
247 (unless (memq 'unread flags)
248 (setq flags (delq 'new flags)))
249 (elmo-global-flags-set flags folder number message-id)
250 (elmo-msgdb-append-entity new-msgdb entity flags)
251 (when (> len elmo-display-progress-threshold)
253 (elmo-display-progress
254 'elmo-maildir-msgdb-create "Creating msgdb..."
255 (/ (* i 100) len)))))
256 (message "Creating msgdb...done")
259 (defun elmo-maildir-cleanup-temporal (dir)
260 ;; Delete files in the tmp dir which are not accessed
261 ;; for more than 36 hours.
262 (let ((cur-time (current-time))
267 (setq last-accessed (nth 4 (file-attributes file)))
268 (when (or (> (- (car cur-time)(car last-accessed)) 1)
269 (and (eq (- (car cur-time)(car last-accessed)) 1)
270 (> (- (cadr cur-time)(cadr last-accessed))
272 (message "Maildir: %d tmp file(s) are cleared."
273 (setq count (1+ count)))
274 (delete-file file))))
275 (directory-files (expand-file-name "tmp" dir)
279 (defun elmo-maildir-update-current (folder)
280 "Move all new msgs to cur in the maildir."
281 (let* ((maildir (elmo-maildir-folder-directory-internal folder))
282 (news (directory-files (expand-file-name "new"
286 ;; cleanup tmp directory.
287 (elmo-maildir-cleanup-temporal maildir)
288 ;; move new msgs to cur directory.
291 (expand-file-name (car news) (expand-file-name "new" maildir))
292 (expand-file-name (concat
294 (unless (string-match
295 (elmo-maildir-adjust-separator ":2,[A-Z]*$")
297 (elmo-maildir-adjust-separator ":2,")))
298 (expand-file-name "cur" maildir)))
299 (setq news (cdr news)))))
301 (defun elmo-maildir-set-mark (filename mark)
302 "Mark the FILENAME file in the maildir. MARK is a character."
304 (elmo-maildir-adjust-separator "^\\(.+:[12],\\)\\(.*\\)$")
306 (let ((flaglist (string-to-char-list (elmo-match-string
308 (unless (memq mark flaglist)
309 (setq flaglist (sort (cons mark flaglist) '<))
310 (rename-file filename
311 (concat (elmo-match-string 1 filename)
312 (char-list-to-string flaglist)))))
313 ;; Rescue no info file in maildir.
314 (rename-file filename
316 (elmo-maildir-adjust-separator ":2,")
317 (char-to-string mark))))
320 (defun elmo-maildir-delete-mark (filename mark)
321 "Mark the FILENAME file in the maildir. MARK is a character."
322 (if (string-match (elmo-maildir-adjust-separator "^\\(.+:2,\\)\\(.*\\)$")
324 (let ((flaglist (string-to-char-list (elmo-match-string
326 (when (memq mark flaglist)
327 (setq flaglist (delq mark flaglist))
328 (rename-file filename
329 (concat (elmo-match-string 1 filename)
331 (char-list-to-string flaglist))))))))
333 (defsubst elmo-maildir-set-mark-msgs (folder locs mark)
335 (elmo-maildir-set-mark
336 (elmo-maildir-message-file-name folder loc)
340 (defsubst elmo-maildir-delete-mark-msgs (folder locs mark)
342 (elmo-maildir-delete-mark
343 (elmo-maildir-message-file-name folder loc)
347 (defsubst elmo-maildir-set-mark-messages (folder locations mark remove)
350 (elmo-maildir-delete-mark-msgs folder locations mark)
351 (elmo-maildir-set-mark-msgs folder locations mark))))
353 (luna-define-method elmo-map-folder-set-flag ((folder elmo-maildir-folder)
355 (let ((spec (cdr (assq flag elmo-maildir-flag-specs))))
357 (elmo-maildir-set-mark-messages folder locations
358 (car spec) (nth 1 spec)))))
360 (luna-define-method elmo-map-folder-unset-flag ((folder elmo-maildir-folder)
362 (let ((spec (cdr (assq flag elmo-maildir-flag-specs))))
364 (elmo-maildir-set-mark-messages folder locations
365 (car spec) (not (nth 1 spec))))))
367 (luna-define-method elmo-folder-list-subfolders
368 ((folder elmo-maildir-folder) &optional one-level)
369 (let ((prefix (concat (elmo-folder-name-internal folder)
370 (unless (string= (elmo-folder-prefix-internal folder)
371 (elmo-folder-name-internal folder))
373 (elmo-list-subdirectories-ignore-regexp
374 "^\\(\\.\\.?\\|cur\\|tmp\\|new\\)$")
375 elmo-have-link-count)
377 (list (elmo-folder-name-internal folder))
378 (elmo-mapcar-list-of-list
379 (function (lambda (x) (concat prefix x)))
380 (elmo-list-subdirectories
381 (elmo-maildir-folder-directory-internal folder)
385 (defvar elmo-maildir-sequence-number-internal 0)
387 (defun elmo-maildir-sequence-number (file)
388 "Get `elmo-maildir' specific sequence number from FILE.
389 Not that FILE is the name without directory."
390 ;; elmo-maildir specific.
391 (if (string-match "^.*_\\([0-9]+\\)\\..*" file)
392 (string-to-number (match-string 1 file))
395 (defun elmo-maildir-make-unique-string ()
396 "This function generates a string that can be used as a unique
397 file name for maildir directories."
398 (let ((cur-time (current-time)))
399 (format "%.0f.%d_%d.%s"
401 (float 65536)) (cadr cur-time))
403 (incf elmo-maildir-sequence-number-internal)
406 (defun elmo-maildir-temporal-filename (basedir)
407 (let ((filename (expand-file-name
408 (concat "tmp/" (elmo-maildir-make-unique-string))
410 (unless (file-exists-p (file-name-directory filename))
411 (make-directory (file-name-directory filename)))
412 (while (file-exists-p filename)
413 ;;; I don't want to wait.
417 (concat "tmp/" (elmo-maildir-make-unique-string))
421 (defun elmo-maildir-move-file (src dst)
422 (or (condition-case nil
424 ;; 1. Try add-link-to-file, then delete the original.
425 ;; This is safe on NFS.
426 (add-name-to-file src dst)
428 ;; It's ok if the delete-file fails;
429 ;; elmo-maildir-cleanup-temporal will catch it later.
433 ;; 2. Even on systems with hardlinks, some filesystems (like AFS)
434 ;; might not support them, so fall back on rename-file. This is
435 ;; our best shot at atomic when add-name-to-file fails.
436 (rename-file src dst)))
438 (luna-define-method elmo-folder-append-buffer ((folder elmo-maildir-folder)
439 &optional flags number)
440 (let ((basedir (elmo-maildir-folder-directory-internal folder))
441 (src-buf (current-buffer))
445 (setq filename (elmo-maildir-temporal-filename basedir))
446 (setq dst-buf (current-buffer))
447 (with-current-buffer src-buf
448 (copy-to-buffer dst-buf (point-min) (point-max)))
449 (as-binary-output-file
450 (write-region (point-min) (point-max) filename nil 'no-msg))
451 (elmo-maildir-move-file
454 (concat "new/" (file-name-nondirectory filename))
456 (elmo-folder-preserve-flags
457 folder (elmo-msgdb-get-message-id-from-buffer) flags)
459 ;; If an error occured, return nil.
462 (luna-define-method elmo-folder-message-file-p ((folder elmo-maildir-folder))
465 (luna-define-method elmo-message-file-name ((folder elmo-maildir-folder)
467 (elmo-maildir-message-file-name
469 (elmo-map-message-location folder number)))
471 (luna-define-method elmo-folder-message-make-temp-file-p
472 ((folder elmo-maildir-folder))
475 (luna-define-method elmo-folder-message-make-temp-files ((folder
480 (let ((temp-dir (elmo-folder-make-temporary-directory folder))
481 (cur-number (or start-number 0)))
482 (dolist (number numbers)
484 (elmo-message-file-name folder number)
486 (int-to-string (if start-number cur-number number))
491 (luna-define-method elmo-folder-append-messages :around
492 ((folder elmo-maildir-folder)
493 src-folder numbers &optional same-number)
494 (if (elmo-folder-message-file-p src-folder)
495 (let ((src-msgdb-exists (not (zerop (elmo-folder-length src-folder))))
496 (dir (elmo-maildir-folder-directory-internal folder))
497 (table (elmo-folder-flag-table folder))
500 (dolist (number numbers)
501 (setq flags (elmo-message-flags src-folder number)
502 filename (elmo-maildir-temporal-filename dir))
504 (elmo-message-file-name src-folder number)
506 (elmo-maildir-move-file
509 (concat "new/" (file-name-nondirectory filename))
511 ;; src folder's msgdb is loaded.
512 (when (setq id (and src-msgdb-exists
513 (elmo-message-field src-folder number
515 (elmo-flag-table-set table id flags))
516 (elmo-progress-notify 'elmo-folder-move-messages))
517 (when (elmo-folder-persistent-p folder)
518 (elmo-folder-close-flag-table folder))
520 (luna-call-next-method)))
522 (luna-define-method elmo-map-folder-delete-messages
523 ((folder elmo-maildir-folder) locations)
525 (dolist (location locations)
526 (setq file (elmo-maildir-message-file-name folder location))
528 (file-writable-p file)
529 (not (file-directory-p file)))
530 (delete-file file))))
533 (luna-define-method elmo-map-message-fetch ((folder elmo-maildir-folder)
535 &optional section unseen)
536 (let ((file (elmo-maildir-message-file-name folder location)))
537 (when (file-exists-p file)
538 (insert-file-contents-as-binary file)
540 (elmo-map-folder-set-flag folder (list location) 'read))
543 (luna-define-method elmo-folder-exists-p ((folder elmo-maildir-folder))
544 (let ((basedir (elmo-maildir-folder-directory-internal folder)))
545 (and (file-directory-p (expand-file-name "new" basedir))
546 (file-directory-p (expand-file-name "cur" basedir))
547 (file-directory-p (expand-file-name "tmp" basedir)))))
549 (luna-define-method elmo-folder-diff ((folder elmo-maildir-folder))
550 (let* ((dir (elmo-maildir-folder-directory-internal folder))
551 (new-len (length (car (elmo-maildir-list-location dir "new"))))
552 (cur-len (length (car (elmo-maildir-list-location dir "cur")))))
553 (cons new-len (+ new-len cur-len))))
555 (luna-define-method elmo-folder-creatable-p ((folder elmo-maildir-folder))
558 (luna-define-method elmo-folder-writable-p ((folder elmo-maildir-folder))
561 (luna-define-method elmo-folder-create ((folder elmo-maildir-folder))
562 (let ((basedir (elmo-maildir-folder-directory-internal folder)))
565 (dolist (dir '("." "new" "cur" "tmp"))
566 (setq dir (expand-file-name dir basedir))
567 (or (file-directory-p dir)
569 (elmo-make-directory dir)
570 (set-file-modes dir 448))))
574 (luna-define-method elmo-folder-delete ((folder elmo-maildir-folder))
575 (let ((msgs (and (elmo-folder-exists-p folder)
576 (elmo-folder-list-messages folder))))
577 (when (yes-or-no-p (format "%sDelete msgdb and substance of \"%s\"? "
578 (if (> (length msgs) 0)
579 (format "%d msg(s) exists. " (length msgs))
581 (elmo-folder-name-internal folder)))
582 (let ((basedir (elmo-maildir-folder-directory-internal folder)))
584 (let ((tmp-files (directory-files
585 (expand-file-name "tmp" basedir)
587 ;; Delete files in tmp.
588 (dolist (file tmp-files)
590 (dolist (dir '("new" "cur" "tmp" "."))
591 (setq dir (expand-file-name dir basedir))
592 (if (not (file-directory-p dir))
594 (elmo-delete-directory dir t))))
596 (elmo-msgdb-delete-path folder)
599 (luna-define-method elmo-folder-rename-internal ((folder elmo-maildir-folder)
601 (let* ((old (elmo-maildir-folder-directory-internal folder))
602 (new (elmo-maildir-folder-directory-internal new-folder))
603 (new-dir (directory-file-name (file-name-directory new))))
604 (unless (file-directory-p old)
605 (error "No such directory: %s" old))
606 (when (file-exists-p new)
607 (error "Already exists directory: %s" new))
608 (unless (file-directory-p new-dir)
609 (elmo-make-directory new-dir))
610 (rename-file old new)
614 (product-provide (provide 'elmo-maildir) (require 'elmo-version))
616 ;;; elmo-maildir.el ends here