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 ;;; ELMO Maildir folder
45 (luna-define-class elmo-maildir-folder
47 (directory unread-locations
50 (luna-define-internal-accessors 'elmo-maildir-folder))
52 (luna-define-method elmo-folder-initialize ((folder
55 (if (file-name-absolute-p name)
56 (elmo-maildir-folder-set-directory-internal
58 (expand-file-name name))
59 (elmo-maildir-folder-set-directory-internal
63 elmo-maildir-folder-path)))
66 (luna-define-method elmo-folder-expand-msgdb-path ((folder
69 (elmo-replace-string-as-filename
70 (elmo-maildir-folder-directory-internal folder))
73 elmo-msgdb-directory)))
75 (defun elmo-maildir-message-file-name (folder location)
76 "Get a file name of the message from FOLDER which corresponded to
78 (let ((file (file-name-completion
82 (elmo-maildir-folder-directory-internal folder)))))
85 (if (eq file t) location file)
88 (elmo-maildir-folder-directory-internal folder))))))
90 (defsubst elmo-maildir-list-location (dir &optional child-dir)
91 (let* ((cur-dir (expand-file-name (or child-dir "cur") dir))
92 (cur (directory-files cur-dir
94 unread-locations flagged-locations answered-locations
95 sym locations flag-list)
99 (if (string-match "^\\([^:]+\\):\\([^:]+\\)$" x)
101 (setq sym (elmo-match-string 1 x)
102 flag-list (string-to-char-list
103 (elmo-match-string 2 x)))
104 (when (memq ?F flag-list)
105 (setq flagged-locations
106 (cons sym flagged-locations)))
107 (when (memq ?R flag-list)
108 (setq answered-locations
109 (cons sym answered-locations)))
110 (unless (memq ?S flag-list)
111 (setq unread-locations
112 (cons sym unread-locations)))
116 (list locations unread-locations flagged-locations answered-locations)))
118 (luna-define-method elmo-map-folder-list-message-locations
119 ((folder elmo-maildir-folder))
120 (elmo-maildir-update-current folder)
121 (let ((locs (elmo-maildir-list-location
122 (elmo-maildir-folder-directory-internal folder))))
123 ;; 0: locations, 1: unread-locs, 2: flagged-locs 3: answered-locs
124 (elmo-maildir-folder-set-unread-locations-internal folder (nth 1 locs))
125 (elmo-maildir-folder-set-flagged-locations-internal folder (nth 2 locs))
126 (elmo-maildir-folder-set-answered-locations-internal folder (nth 3 locs))
129 (luna-define-method elmo-map-folder-list-unreads
130 ((folder elmo-maildir-folder))
131 (elmo-maildir-folder-unread-locations-internal folder))
133 (luna-define-method elmo-map-folder-list-importants
134 ((folder elmo-maildir-folder))
135 (elmo-maildir-folder-flagged-locations-internal folder))
137 (luna-define-method elmo-map-folder-list-answereds
138 ((folder elmo-maildir-folder))
139 (elmo-maildir-folder-answered-locations-internal folder))
141 (luna-define-method elmo-folder-msgdb-create ((folder elmo-maildir-folder)
143 (let* ((unread-list (elmo-maildir-folder-unread-locations-internal folder))
144 (flagged-list (elmo-maildir-folder-flagged-locations-internal folder))
145 (answered-list (elmo-maildir-folder-answered-locations-internal
147 (len (length numbers))
148 (new-msgdb (elmo-make-msgdb))
150 entity message-id flags location)
151 (message "Creating msgdb...")
152 (dolist (number numbers)
153 (setq location (elmo-map-message-location folder number))
155 (elmo-msgdb-create-overview-entity-from-file
157 (elmo-maildir-message-file-name folder location)))
159 (setq message-id (elmo-message-entity-field entity 'message-id)
160 ;; Precede flag-table to file-info.
162 (elmo-flag-table-get flag-table message-id)))
164 ;; Already flagged on filename (precede it to flag-table).
165 (when (member location flagged-list)
166 (or (memq 'important flags)
167 (setq flags (cons 'important flags))))
168 (when (member location answered-list)
169 (or (memq 'answered flags)
170 (setq flags (cons 'answered flags))))
171 (unless (member location unread-list)
172 (and (memq 'unread flags)
173 (setq flags (delq 'unread flags))))
175 ;; Update filename's info portion according to the flag-table.
176 (when (and (memq 'important flags)
177 (not (member location flagged-list)))
178 (elmo-maildir-set-mark
179 (elmo-maildir-message-file-name folder location)
181 ;; Append to flagged location list.
182 (elmo-maildir-folder-set-flagged-locations-internal
185 (elmo-maildir-folder-flagged-locations-internal
187 (setq flags (delq 'unread flags)))
188 (when (and (memq 'answered flags)
189 (not (member location answered-list)))
190 (elmo-maildir-set-mark
191 (elmo-maildir-message-file-name folder location)
193 ;; Append to answered location list.
194 (elmo-maildir-folder-set-answered-locations-internal
197 (elmo-maildir-folder-answered-locations-internal folder)))
198 (setq flags (delq 'unread flags)))
199 (when (and (not (memq 'unread flags))
200 (member location unread-list))
201 (elmo-maildir-set-mark
202 (elmo-maildir-message-file-name folder location)
204 ;; Delete from unread locations.
205 (elmo-maildir-folder-set-unread-locations-internal
208 (elmo-maildir-folder-unread-locations-internal
210 (unless (memq 'unread flags)
211 (setq flags (delq 'new flags)))
212 (elmo-global-flags-set flags folder number message-id)
213 (elmo-msgdb-append-entity new-msgdb entity flags)
214 (when (> len elmo-display-progress-threshold)
216 (elmo-display-progress
217 'elmo-maildir-msgdb-create "Creating msgdb..."
218 (/ (* i 100) len)))))
219 (message "Creating msgdb...done")
220 (elmo-msgdb-sort-by-date new-msgdb)))
222 (defun elmo-maildir-cleanup-temporal (dir)
223 ;; Delete files in the tmp dir which are not accessed
224 ;; for more than 36 hours.
225 (let ((cur-time (current-time))
230 (setq last-accessed (nth 4 (file-attributes file)))
231 (when (or (> (- (car cur-time)(car last-accessed)) 1)
232 (and (eq (- (car cur-time)(car last-accessed)) 1)
233 (> (- (cadr cur-time)(cadr last-accessed))
235 (message "Maildir: %d tmp file(s) are cleared."
236 (setq count (1+ count)))
237 (delete-file file))))
238 (directory-files (expand-file-name "tmp" dir)
242 (defun elmo-maildir-update-current (folder)
243 "Move all new msgs to cur in the maildir."
244 (let* ((maildir (elmo-maildir-folder-directory-internal folder))
245 (news (directory-files (expand-file-name "new"
249 ;; cleanup tmp directory.
250 (elmo-maildir-cleanup-temporal maildir)
251 ;; move new msgs to cur directory.
254 (expand-file-name (car news) (expand-file-name "new" maildir))
255 (expand-file-name (concat
257 (unless (string-match ":2,[A-Z]*$" (car news))
259 (expand-file-name "cur" maildir)))
260 (setq news (cdr news)))))
262 (defun elmo-maildir-set-mark (filename mark)
263 "Mark the FILENAME file in the maildir. MARK is a character."
264 (if (string-match "^\\([^:]+:[12],\\)\\(.*\\)$" filename)
265 (let ((flaglist (string-to-char-list (elmo-match-string
267 (unless (memq mark flaglist)
268 (setq flaglist (sort (cons mark flaglist) '<))
269 (rename-file filename
270 (concat (elmo-match-string 1 filename)
271 (char-list-to-string flaglist)))))
272 ;; Rescue no info file in maildir.
273 (rename-file filename
274 (concat filename ":2," (char-to-string mark))))
277 (defun elmo-maildir-delete-mark (filename mark)
278 "Mark the FILENAME file in the maildir. MARK is a character."
279 (if (string-match "^\\([^:]+:2,\\)\\(.*\\)$" filename)
280 (let ((flaglist (string-to-char-list (elmo-match-string
282 (when (memq mark flaglist)
283 (setq flaglist (delq mark flaglist))
284 (rename-file filename
285 (concat (elmo-match-string 1 filename)
287 (char-list-to-string flaglist))))))))
289 (defsubst elmo-maildir-set-mark-msgs (folder locs mark)
291 (elmo-maildir-set-mark
292 (elmo-maildir-message-file-name folder loc)
296 (defsubst elmo-maildir-delete-mark-msgs (folder locs mark)
298 (elmo-maildir-delete-mark
299 (elmo-maildir-message-file-name folder loc)
303 (luna-define-method elmo-map-folder-flag-as-important ((folder elmo-maildir-folder)
305 (elmo-maildir-set-mark-msgs folder locs ?F))
307 (luna-define-method elmo-map-folder-unflag-important ((folder elmo-maildir-folder)
309 (elmo-maildir-delete-mark-msgs folder locs ?F))
311 (luna-define-method elmo-map-folder-flag-as-read ((folder elmo-maildir-folder)
313 (elmo-maildir-set-mark-msgs folder locs ?S))
315 (luna-define-method elmo-map-folder-unflag-read ((folder elmo-maildir-folder)
317 (elmo-maildir-delete-mark-msgs folder locs ?S))
319 (luna-define-method elmo-map-folder-flag-as-answered ((folder
322 (elmo-maildir-set-mark-msgs folder locs ?R))
324 (luna-define-method elmo-map-folder-unflag-answered ((folder
327 (elmo-maildir-delete-mark-msgs folder locs ?R))
329 (luna-define-method elmo-folder-list-subfolders
330 ((folder elmo-maildir-folder) &optional one-level)
331 (let ((prefix (concat (elmo-folder-name-internal folder)
332 (unless (string= (elmo-folder-prefix-internal folder)
333 (elmo-folder-name-internal folder))
335 (elmo-list-subdirectories-ignore-regexp
336 "^\\(\\.\\.?\\|cur\\|tmp\\|new\\)$")
337 elmo-have-link-count)
339 (list (elmo-folder-name-internal folder))
340 (elmo-mapcar-list-of-list
341 (function (lambda (x) (concat prefix x)))
342 (elmo-list-subdirectories
343 (elmo-maildir-folder-directory-internal folder)
347 (defvar elmo-maildir-sequence-number-internal 0)
350 ((>= emacs-major-version 19)
351 (defun elmo-maildir-make-unique-string ()
352 "This function generates a string that can be used as a unique
353 file name for maildir directories."
354 (let ((cur-time (current-time)))
355 (format "%.0f.%d_%d.%s"
357 (float 65536)) (cadr cur-time))
359 (incf elmo-maildir-sequence-number-internal)
361 ((eq emacs-major-version 18)
362 ;; A fake function for v18
363 (defun elmo-maildir-make-unique-string ()
364 "This function generates a string that can be used as a unique
365 file name for maildir directories."
366 (unless (fboundp 'float-to-string)
367 (load-library "float"))
368 (let ((time (current-time)))
372 (f+ (f* (f (car time))
377 (% (abs (random t)) 10000); dummy pid
380 (defun elmo-maildir-temporal-filename (basedir)
381 (let ((filename (expand-file-name
382 (concat "tmp/" (elmo-maildir-make-unique-string))
384 (unless (file-exists-p (file-name-directory filename))
385 (make-directory (file-name-directory filename)))
386 (while (file-exists-p filename)
387 ;;; I don't want to wait.
391 (concat "tmp/" (elmo-maildir-make-unique-string))
395 (luna-define-method elmo-folder-append-buffer ((folder elmo-maildir-folder)
396 &optional status number)
397 (let ((basedir (elmo-maildir-folder-directory-internal folder))
398 (src-buf (current-buffer))
402 (setq filename (elmo-maildir-temporal-filename basedir))
403 (setq dst-buf (current-buffer))
404 (with-current-buffer src-buf
405 (copy-to-buffer dst-buf (point-min) (point-max)))
406 (as-binary-output-file
407 (write-region (point-min) (point-max) filename nil 'no-msg))
408 ;; add link from new.
409 (elmo-add-name-to-file
412 (concat "new/" (file-name-nondirectory filename))
415 ;; If an error occured, return nil.
418 (luna-define-method elmo-folder-message-file-p ((folder elmo-maildir-folder))
421 (luna-define-method elmo-message-file-name ((folder elmo-maildir-folder)
423 (elmo-maildir-message-file-name
425 (elmo-map-message-location folder number)))
427 (luna-define-method elmo-folder-message-make-temp-file-p
428 ((folder elmo-maildir-folder))
431 (luna-define-method elmo-folder-message-make-temp-files ((folder
436 (let ((temp-dir (elmo-folder-make-temporary-directory folder))
437 (cur-number (if start-number 0)))
438 (dolist (number numbers)
440 (elmo-message-file-name folder number)
442 (int-to-string (if start-number (incf cur-number) number))
446 (luna-define-method elmo-folder-append-messages :around
447 ((folder elmo-maildir-folder)
448 src-folder numbers &optional same-number)
449 (if (elmo-folder-message-file-p src-folder)
450 (let ((src-msgdb-exists (not (zerop (elmo-folder-length src-folder))))
451 (dir (elmo-maildir-folder-directory-internal folder))
452 (table (elmo-flag-table-load (elmo-folder-msgdb-path folder)))
455 (dolist (number numbers)
456 (setq flags (elmo-message-flags src-folder (car numbers))
457 filename (elmo-maildir-temporal-filename dir))
459 (elmo-message-file-name src-folder number)
461 (elmo-add-name-to-file
464 (concat "new/" (file-name-nondirectory filename))
466 ;; src folder's msgdb is loaded.
467 (when (setq id (and src-msgdb-exists
468 (elmo-message-field src-folder (car numbers)
470 (elmo-flag-table-set table id flags))
471 (elmo-progress-notify 'elmo-folder-move-messages))
472 (when (elmo-folder-persistent-p folder)
473 (elmo-flag-table-save (elmo-folder-msgdb-path folder) table))
475 (luna-call-next-method)))
477 (luna-define-method elmo-map-folder-delete-messages
478 ((folder elmo-maildir-folder) locations)
480 (dolist (location locations)
481 (setq file (elmo-maildir-message-file-name folder location))
483 (file-writable-p file)
484 (not (file-directory-p file)))
485 (delete-file file)))))
487 (luna-define-method elmo-map-message-fetch ((folder elmo-maildir-folder)
489 &optional section unseen)
490 (let ((file (elmo-maildir-message-file-name folder location)))
491 (when (file-exists-p file)
492 (insert-file-contents-as-binary file))))
494 (luna-define-method elmo-folder-exists-p ((folder elmo-maildir-folder))
495 (let ((basedir (elmo-maildir-folder-directory-internal folder)))
496 (and (file-directory-p (expand-file-name "new" basedir))
497 (file-directory-p (expand-file-name "cur" basedir))
498 (file-directory-p (expand-file-name "tmp" basedir)))))
500 (luna-define-method elmo-folder-diff ((folder elmo-maildir-folder))
501 (let* ((dir (elmo-maildir-folder-directory-internal folder))
502 (new-len (length (car (elmo-maildir-list-location dir "new"))))
503 (cur-len (length (car (elmo-maildir-list-location dir "cur")))))
504 (cons new-len (+ new-len cur-len))))
506 (luna-define-method elmo-folder-creatable-p ((folder elmo-maildir-folder))
509 (luna-define-method elmo-folder-writable-p ((folder elmo-maildir-folder))
512 (luna-define-method elmo-folder-create ((folder elmo-maildir-folder))
513 (let ((basedir (elmo-maildir-folder-directory-internal folder)))
516 (dolist (dir '("." "new" "cur" "tmp"))
517 (setq dir (expand-file-name dir basedir))
518 (or (file-directory-p dir)
520 (elmo-make-directory dir)
521 (set-file-modes dir 448))))
525 (luna-define-method elmo-folder-delete ((folder elmo-maildir-folder))
526 (let ((msgs (and (elmo-folder-exists-p folder)
527 (elmo-folder-list-messages folder))))
528 (when (yes-or-no-p (format "%sDelete msgdb and substance of \"%s\"? "
529 (if (> (length msgs) 0)
530 (format "%d msg(s) exists. " (length msgs))
532 (elmo-folder-name-internal folder)))
533 (let ((basedir (elmo-maildir-folder-directory-internal folder)))
535 (let ((tmp-files (directory-files
536 (expand-file-name "tmp" basedir)
538 ;; Delete files in tmp.
539 (dolist (file tmp-files)
541 (dolist (dir '("new" "cur" "tmp" "."))
542 (setq dir (expand-file-name dir basedir))
543 (if (not (file-directory-p dir))
545 (elmo-delete-directory dir t))))
547 (elmo-msgdb-delete-path folder)
550 (luna-define-method elmo-folder-rename-internal ((folder elmo-maildir-folder)
552 (let* ((old (elmo-maildir-folder-directory-internal folder))
553 (new (elmo-maildir-folder-directory-internal new-folder))
554 (new-dir (directory-file-name (file-name-directory new))))
555 (unless (file-directory-p old)
556 (error "No such directory: %s" old))
557 (when (file-exists-p new)
558 (error "Already exists directory: %s" new))
559 (unless (file-directory-p new-dir)
560 (elmo-make-directory new-dir))
561 (rename-file old new)
565 (product-provide (provide 'elmo-maildir) (require 'elmo-version))
567 ;;; elmo-maildir.el ends here