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 ;; Decided at compile time.
49 (defcustom elmo-maildir-separator
50 (if (memq system-type '(windows-nt)) ?\- ?:)
51 "Character separating the id section from the flags section.
52 According to the maildir specification, this should be a colon (?:),
53 but some file systems don't support colons in filenames."
57 (defmacro elmo-maildir-adjust-separator (string)
58 `(if (= elmo-maildir-separator ?:)
60 (elmo-replace-in-string
61 ,string ":" (char-to-string elmo-maildir-separator))))
63 ;;; ELMO Maildir folder
65 (luna-define-class elmo-maildir-folder
67 (directory unread-locations
70 (luna-define-internal-accessors 'elmo-maildir-folder))
72 (luna-define-method elmo-folder-initialize ((folder
75 (if (file-name-absolute-p name)
76 (elmo-maildir-folder-set-directory-internal
78 (expand-file-name name))
79 (elmo-maildir-folder-set-directory-internal
83 elmo-maildir-folder-path)))
86 (luna-define-method elmo-folder-expand-msgdb-path ((folder
89 (elmo-replace-string-as-filename
90 (elmo-maildir-folder-directory-internal folder))
93 elmo-msgdb-directory)))
95 (defun elmo-maildir-message-file-name (folder location)
96 "Get a file name of the message from FOLDER which corresponded to
98 (let ((file (file-name-completion
102 (elmo-maildir-folder-directory-internal folder)))))
105 (if (eq file t) location file)
108 (elmo-maildir-folder-directory-internal folder))))))
110 (defsubst elmo-maildir-list-location (dir &optional child-dir)
111 (let* ((cur-dir (expand-file-name (or child-dir "cur") dir))
112 (cur (directory-files cur-dir
114 unread-locations flagged-locations answered-locations
115 sym locations flag-list)
120 (elmo-maildir-adjust-separator "^\\([^:]+\\):\\([^:]+\\)$")
123 (setq sym (elmo-match-string 1 x)
124 flag-list (string-to-char-list
125 (elmo-match-string 2 x)))
126 (when (memq ?F flag-list)
127 (setq flagged-locations
128 (cons sym flagged-locations)))
129 (when (memq ?R flag-list)
130 (setq answered-locations
131 (cons sym answered-locations)))
132 (unless (memq ?S flag-list)
133 (setq unread-locations
134 (cons sym unread-locations)))
138 (list locations unread-locations flagged-locations answered-locations)))
140 (luna-define-method elmo-map-folder-list-message-locations
141 ((folder elmo-maildir-folder))
142 (elmo-maildir-update-current folder)
143 (let ((locs (elmo-maildir-list-location
144 (elmo-maildir-folder-directory-internal folder))))
145 ;; 0: locations, 1: unread-locs, 2: flagged-locs 3: answered-locs
146 (elmo-maildir-folder-set-unread-locations-internal folder (nth 1 locs))
147 (elmo-maildir-folder-set-flagged-locations-internal folder (nth 2 locs))
148 (elmo-maildir-folder-set-answered-locations-internal folder (nth 3 locs))
151 (luna-define-method elmo-map-folder-list-flagged ((folder elmo-maildir-folder)
155 (elmo-maildir-folder-unread-locations-internal folder))
157 (elmo-maildir-folder-flagged-locations-internal folder))
159 (elmo-maildir-folder-answered-locations-internal folder))
163 (luna-define-method elmo-folder-msgdb-create ((folder elmo-maildir-folder)
165 (let* ((unread-list (elmo-maildir-folder-unread-locations-internal folder))
166 (flagged-list (elmo-maildir-folder-flagged-locations-internal folder))
167 (answered-list (elmo-maildir-folder-answered-locations-internal
169 (len (length numbers))
170 (new-msgdb (elmo-make-msgdb))
172 entity message-id flags location)
173 (message "Creating msgdb...")
174 (dolist (number numbers)
175 (setq location (elmo-map-message-location folder number))
177 (elmo-msgdb-create-message-entity-from-file
178 (elmo-msgdb-message-entity-handler new-msgdb)
180 (elmo-maildir-message-file-name folder location)))
182 (setq message-id (elmo-message-entity-field entity 'message-id)
183 ;; Precede flag-table to file-info.
185 (elmo-flag-table-get flag-table message-id)))
187 ;; Already flagged on filename (precede it to flag-table).
188 (when (member location flagged-list)
189 (or (memq 'important flags)
190 (setq flags (cons 'important flags))))
191 (when (member location answered-list)
192 (or (memq 'answered flags)
193 (setq flags (cons 'answered flags))))
194 (unless (member location unread-list)
195 (and (memq 'unread flags)
196 (setq flags (delq 'unread flags))))
198 ;; Update filename's info portion according to the flag-table.
199 (when (and (memq 'important flags)
200 (not (member location flagged-list)))
201 (elmo-maildir-set-mark
202 (elmo-maildir-message-file-name folder location)
204 ;; Append to flagged location list.
205 (elmo-maildir-folder-set-flagged-locations-internal
208 (elmo-maildir-folder-flagged-locations-internal
210 (setq flags (delq 'unread flags)))
211 (when (and (memq 'answered flags)
212 (not (member location answered-list)))
213 (elmo-maildir-set-mark
214 (elmo-maildir-message-file-name folder location)
216 ;; Append to answered location list.
217 (elmo-maildir-folder-set-answered-locations-internal
220 (elmo-maildir-folder-answered-locations-internal folder)))
221 (setq flags (delq 'unread flags)))
222 (when (and (not (memq 'unread flags))
223 (member location unread-list))
224 (elmo-maildir-set-mark
225 (elmo-maildir-message-file-name folder location)
227 ;; Delete from unread locations.
228 (elmo-maildir-folder-set-unread-locations-internal
231 (elmo-maildir-folder-unread-locations-internal
233 (unless (memq 'unread flags)
234 (setq flags (delq 'new flags)))
235 (elmo-global-flags-set flags folder number message-id)
236 (elmo-msgdb-append-entity new-msgdb entity flags)
237 (when (> len elmo-display-progress-threshold)
239 (elmo-display-progress
240 'elmo-maildir-msgdb-create "Creating msgdb..."
241 (/ (* i 100) len)))))
242 (message "Creating msgdb...done")
243 (elmo-msgdb-sort-by-date new-msgdb)))
245 (defun elmo-maildir-cleanup-temporal (dir)
246 ;; Delete files in the tmp dir which are not accessed
247 ;; for more than 36 hours.
248 (let ((cur-time (current-time))
253 (setq last-accessed (nth 4 (file-attributes file)))
254 (when (or (> (- (car cur-time)(car last-accessed)) 1)
255 (and (eq (- (car cur-time)(car last-accessed)) 1)
256 (> (- (cadr cur-time)(cadr last-accessed))
258 (message "Maildir: %d tmp file(s) are cleared."
259 (setq count (1+ count)))
260 (delete-file file))))
261 (directory-files (expand-file-name "tmp" dir)
265 (defun elmo-maildir-update-current (folder)
266 "Move all new msgs to cur in the maildir."
267 (let* ((maildir (elmo-maildir-folder-directory-internal folder))
268 (news (directory-files (expand-file-name "new"
272 ;; cleanup tmp directory.
273 (elmo-maildir-cleanup-temporal maildir)
274 ;; move new msgs to cur directory.
277 (expand-file-name (car news) (expand-file-name "new" maildir))
278 (expand-file-name (concat
280 (unless (string-match
281 (elmo-maildir-adjust-separator ":2,[A-Z]*$")
283 (elmo-maildir-adjust-separator ":2,")))
284 (expand-file-name "cur" maildir)))
285 (setq news (cdr news)))))
287 (defun elmo-maildir-set-mark (filename mark)
288 "Mark the FILENAME file in the maildir. MARK is a character."
290 (elmo-maildir-adjust-separator "^\\([^:]+:[12],\\)\\(.*\\)$")
292 (let ((flaglist (string-to-char-list (elmo-match-string
294 (unless (memq mark flaglist)
295 (setq flaglist (sort (cons mark flaglist) '<))
296 (rename-file filename
297 (concat (elmo-match-string 1 filename)
298 (char-list-to-string flaglist)))))
299 ;; Rescue no info file in maildir.
300 (rename-file filename
302 (elmo-maildir-adjust-separator ":2,")
303 (char-to-string mark))))
306 (defun elmo-maildir-delete-mark (filename mark)
307 "Mark the FILENAME file in the maildir. MARK is a character."
308 (if (string-match (elmo-maildir-adjust-separator "^\\([^:]+:2,\\)\\(.*\\)$")
310 (let ((flaglist (string-to-char-list (elmo-match-string
312 (when (memq mark flaglist)
313 (setq flaglist (delq mark flaglist))
314 (rename-file filename
315 (concat (elmo-match-string 1 filename)
317 (char-list-to-string flaglist))))))))
319 (defsubst elmo-maildir-set-mark-msgs (folder locs mark)
321 (elmo-maildir-set-mark
322 (elmo-maildir-message-file-name folder loc)
326 (defsubst elmo-maildir-delete-mark-msgs (folder locs mark)
328 (elmo-maildir-delete-mark
329 (elmo-maildir-message-file-name folder loc)
333 (defsubst elmo-maildir-set-mark-messages (folder locations mark remove)
336 (elmo-maildir-delete-mark-msgs folder locations mark)
337 (elmo-maildir-set-mark-msgs folder locations mark))))
339 (luna-define-method elmo-map-folder-set-flag ((folder elmo-maildir-folder)
341 (let ((spec (cdr (assq flag elmo-maildir-flag-specs))))
343 (elmo-maildir-set-mark-messages folder locations
344 (car spec) (nth 1 spec)))))
346 (luna-define-method elmo-map-folder-unset-flag ((folder elmo-maildir-folder)
348 (let ((spec (cdr (assq flag elmo-maildir-flag-specs))))
350 (elmo-maildir-set-mark-messages folder locations
351 (car spec) (not (nth 1 spec))))))
353 (luna-define-method elmo-folder-list-subfolders
354 ((folder elmo-maildir-folder) &optional one-level)
355 (let ((prefix (concat (elmo-folder-name-internal folder)
356 (unless (string= (elmo-folder-prefix-internal folder)
357 (elmo-folder-name-internal folder))
359 (elmo-list-subdirectories-ignore-regexp
360 "^\\(\\.\\.?\\|cur\\|tmp\\|new\\)$")
361 elmo-have-link-count)
363 (list (elmo-folder-name-internal folder))
364 (elmo-mapcar-list-of-list
365 (function (lambda (x) (concat prefix x)))
366 (elmo-list-subdirectories
367 (elmo-maildir-folder-directory-internal folder)
371 (defvar elmo-maildir-sequence-number-internal 0)
374 ((>= emacs-major-version 19)
375 (defun elmo-maildir-make-unique-string ()
376 "This function generates a string that can be used as a unique
377 file name for maildir directories."
378 (let ((cur-time (current-time)))
379 (format "%.0f.%d_%d.%s"
381 (float 65536)) (cadr cur-time))
383 (incf elmo-maildir-sequence-number-internal)
385 ((eq emacs-major-version 18)
386 ;; A fake function for v18
387 (defun elmo-maildir-make-unique-string ()
388 "This function generates a string that can be used as a unique
389 file name for maildir directories."
390 (unless (fboundp 'float-to-string)
391 (load-library "float"))
392 (let ((time (current-time)))
396 (f+ (f* (f (car time))
401 (% (abs (random t)) 10000); dummy pid
404 (defun elmo-maildir-temporal-filename (basedir)
405 (let ((filename (expand-file-name
406 (concat "tmp/" (elmo-maildir-make-unique-string))
408 (unless (file-exists-p (file-name-directory filename))
409 (make-directory (file-name-directory filename)))
410 (while (file-exists-p filename)
411 ;;; I don't want to wait.
415 (concat "tmp/" (elmo-maildir-make-unique-string))
419 (defun elmo-maildir-move-file (src dst)
420 (or (condition-case nil
422 ;; 1. Try add-link-to-file, then delete the original.
423 ;; This is safe on NFS.
424 (add-name-to-file src dst)
426 ;; It's ok if the delete-file fails;
427 ;; elmo-maildir-cleanup-temporal will catch it later.
431 ;; 2. Even on systems with hardlinks, some filesystems (like AFS)
432 ;; might not support them, so fall back on rename-file. This is
433 ;; our best shot at atomic when add-name-to-file fails.
434 (rename-file src dst)))
436 (luna-define-method elmo-folder-append-buffer ((folder elmo-maildir-folder)
437 &optional flags number)
438 (let ((basedir (elmo-maildir-folder-directory-internal folder))
439 (src-buf (current-buffer))
443 (setq filename (elmo-maildir-temporal-filename basedir))
444 (setq dst-buf (current-buffer))
445 (with-current-buffer src-buf
446 (copy-to-buffer dst-buf (point-min) (point-max)))
447 (as-binary-output-file
448 (write-region (point-min) (point-max) filename nil 'no-msg))
449 (elmo-maildir-move-file
452 (concat "new/" (file-name-nondirectory filename))
454 (elmo-folder-preserve-flags
455 folder (elmo-msgdb-get-message-id-from-buffer) flags)
457 ;; If an error occured, return nil.
460 (luna-define-method elmo-folder-message-file-p ((folder elmo-maildir-folder))
463 (luna-define-method elmo-message-file-name ((folder elmo-maildir-folder)
465 (elmo-maildir-message-file-name
467 (elmo-map-message-location folder number)))
469 (luna-define-method elmo-folder-message-make-temp-file-p
470 ((folder elmo-maildir-folder))
473 (luna-define-method elmo-folder-message-make-temp-files ((folder
478 (let ((temp-dir (elmo-folder-make-temporary-directory folder))
479 (cur-number (if start-number 0)))
480 (dolist (number numbers)
482 (elmo-message-file-name folder number)
484 (int-to-string (if start-number (incf cur-number) number))
488 (luna-define-method elmo-folder-append-messages :around
489 ((folder elmo-maildir-folder)
490 src-folder numbers &optional same-number)
491 (if (elmo-folder-message-file-p src-folder)
492 (let ((src-msgdb-exists (not (zerop (elmo-folder-length src-folder))))
493 (dir (elmo-maildir-folder-directory-internal folder))
494 (table (elmo-folder-flag-table folder))
497 (dolist (number numbers)
498 (setq flags (elmo-message-flags src-folder (car numbers))
499 filename (elmo-maildir-temporal-filename dir))
501 (elmo-message-file-name src-folder number)
503 (elmo-maildir-move-file
506 (concat "new/" (file-name-nondirectory filename))
508 ;; src folder's msgdb is loaded.
509 (when (setq id (and src-msgdb-exists
510 (elmo-message-field src-folder (car numbers)
512 (elmo-flag-table-set table id flags))
513 (elmo-progress-notify 'elmo-folder-move-messages))
514 (when (elmo-folder-persistent-p folder)
515 (elmo-folder-close-flag-table folder))
517 (luna-call-next-method)))
519 (luna-define-method elmo-map-folder-delete-messages
520 ((folder elmo-maildir-folder) locations)
522 (dolist (location locations)
523 (setq file (elmo-maildir-message-file-name folder location))
525 (file-writable-p file)
526 (not (file-directory-p file)))
527 (delete-file file))))
530 (luna-define-method elmo-map-message-fetch ((folder elmo-maildir-folder)
532 &optional section unseen)
533 (let ((file (elmo-maildir-message-file-name folder location)))
534 (when (file-exists-p file)
535 (insert-file-contents-as-binary file)
537 (elmo-map-folder-set-flag folder (list location) 'read))
540 (luna-define-method elmo-folder-exists-p ((folder elmo-maildir-folder))
541 (let ((basedir (elmo-maildir-folder-directory-internal folder)))
542 (and (file-directory-p (expand-file-name "new" basedir))
543 (file-directory-p (expand-file-name "cur" basedir))
544 (file-directory-p (expand-file-name "tmp" basedir)))))
546 (luna-define-method elmo-folder-diff ((folder elmo-maildir-folder))
547 (let* ((dir (elmo-maildir-folder-directory-internal folder))
548 (new-len (length (car (elmo-maildir-list-location dir "new"))))
549 (cur-len (length (car (elmo-maildir-list-location dir "cur")))))
550 (cons new-len (+ new-len cur-len))))
552 (luna-define-method elmo-folder-creatable-p ((folder elmo-maildir-folder))
555 (luna-define-method elmo-folder-writable-p ((folder elmo-maildir-folder))
558 (luna-define-method elmo-folder-create ((folder elmo-maildir-folder))
559 (let ((basedir (elmo-maildir-folder-directory-internal folder)))
562 (dolist (dir '("." "new" "cur" "tmp"))
563 (setq dir (expand-file-name dir basedir))
564 (or (file-directory-p dir)
566 (elmo-make-directory dir)
567 (set-file-modes dir 448))))
571 (luna-define-method elmo-folder-delete ((folder elmo-maildir-folder))
572 (let ((msgs (and (elmo-folder-exists-p folder)
573 (elmo-folder-list-messages folder))))
574 (when (yes-or-no-p (format "%sDelete msgdb and substance of \"%s\"? "
575 (if (> (length msgs) 0)
576 (format "%d msg(s) exists. " (length msgs))
578 (elmo-folder-name-internal folder)))
579 (let ((basedir (elmo-maildir-folder-directory-internal folder)))
581 (let ((tmp-files (directory-files
582 (expand-file-name "tmp" basedir)
584 ;; Delete files in tmp.
585 (dolist (file tmp-files)
587 (dolist (dir '("new" "cur" "tmp" "."))
588 (setq dir (expand-file-name dir basedir))
589 (if (not (file-directory-p dir))
591 (elmo-delete-directory dir t))))
593 (elmo-msgdb-delete-path folder)
596 (luna-define-method elmo-folder-rename-internal ((folder elmo-maildir-folder)
598 (let* ((old (elmo-maildir-folder-directory-internal folder))
599 (new (elmo-maildir-folder-directory-internal new-folder))
600 (new-dir (directory-file-name (file-name-directory new))))
601 (unless (file-directory-p old)
602 (error "No such directory: %s" old))
603 (when (file-exists-p new)
604 (error "Already exists directory: %s" new))
605 (unless (file-directory-p new-dir)
606 (elmo-make-directory new-dir))
607 (rename-file old new)
611 (product-provide (provide 'elmo-maildir) (require 'elmo-version))
613 ;;; elmo-maildir.el ends here