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 ;;; ELMO Maildir folder
50 (luna-define-class elmo-maildir-folder
52 (directory unread-locations
55 (luna-define-internal-accessors 'elmo-maildir-folder))
57 (luna-define-method elmo-folder-initialize ((folder
60 (if (file-name-absolute-p name)
61 (elmo-maildir-folder-set-directory-internal
63 (expand-file-name name))
64 (elmo-maildir-folder-set-directory-internal
68 elmo-maildir-folder-path)))
71 (luna-define-method elmo-folder-expand-msgdb-path ((folder
74 (elmo-replace-string-as-filename
75 (elmo-maildir-folder-directory-internal folder))
78 elmo-msgdb-directory)))
80 (defun elmo-maildir-message-file-name (folder location)
81 "Get a file name of the message from FOLDER which corresponded to
83 (let ((file (file-name-completion
87 (elmo-maildir-folder-directory-internal folder)))))
90 (if (eq file t) location file)
93 (elmo-maildir-folder-directory-internal folder))))))
95 (defsubst elmo-maildir-list-location (dir &optional child-dir)
96 (let* ((cur-dir (expand-file-name (or child-dir "cur") dir))
97 (cur (directory-files cur-dir
99 unread-locations flagged-locations answered-locations
100 sym locations flag-list)
104 (if (string-match "^\\([^:]+\\):\\([^:]+\\)$" x)
106 (setq sym (elmo-match-string 1 x)
107 flag-list (string-to-char-list
108 (elmo-match-string 2 x)))
109 (when (memq ?F flag-list)
110 (setq flagged-locations
111 (cons sym flagged-locations)))
112 (when (memq ?R flag-list)
113 (setq answered-locations
114 (cons sym answered-locations)))
115 (unless (memq ?S flag-list)
116 (setq unread-locations
117 (cons sym unread-locations)))
121 (list locations unread-locations flagged-locations answered-locations)))
123 (luna-define-method elmo-map-folder-list-message-locations
124 ((folder elmo-maildir-folder))
125 (elmo-maildir-update-current folder)
126 (let ((locs (elmo-maildir-list-location
127 (elmo-maildir-folder-directory-internal folder))))
128 ;; 0: locations, 1: unread-locs, 2: flagged-locs 3: answered-locs
129 (elmo-maildir-folder-set-unread-locations-internal folder (nth 1 locs))
130 (elmo-maildir-folder-set-flagged-locations-internal folder (nth 2 locs))
131 (elmo-maildir-folder-set-answered-locations-internal folder (nth 3 locs))
134 (luna-define-method elmo-map-folder-list-flagged ((folder elmo-maildir-folder)
138 (elmo-maildir-folder-unread-locations-internal folder))
140 (elmo-maildir-folder-flagged-locations-internal folder))
142 (elmo-maildir-folder-answered-locations-internal folder))
146 (luna-define-method elmo-folder-msgdb-create ((folder elmo-maildir-folder)
148 (let* ((unread-list (elmo-maildir-folder-unread-locations-internal folder))
149 (flagged-list (elmo-maildir-folder-flagged-locations-internal folder))
150 (answered-list (elmo-maildir-folder-answered-locations-internal
152 (len (length numbers))
153 (new-msgdb (elmo-make-msgdb))
155 entity message-id flags location)
156 (message "Creating msgdb...")
157 (dolist (number numbers)
158 (setq location (elmo-map-message-location folder number))
160 (elmo-msgdb-create-message-entity-from-file
161 (elmo-msgdb-message-entity-handler new-msgdb)
163 (elmo-maildir-message-file-name folder location)))
165 (setq message-id (elmo-message-entity-field entity 'message-id)
166 ;; Precede flag-table to file-info.
168 (elmo-flag-table-get flag-table message-id)))
170 ;; Already flagged on filename (precede it to flag-table).
171 (when (member location flagged-list)
172 (or (memq 'important flags)
173 (setq flags (cons 'important flags))))
174 (when (member location answered-list)
175 (or (memq 'answered flags)
176 (setq flags (cons 'answered flags))))
177 (unless (member location unread-list)
178 (and (memq 'unread flags)
179 (setq flags (delq 'unread flags))))
181 ;; Update filename's info portion according to the flag-table.
182 (when (and (memq 'important flags)
183 (not (member location flagged-list)))
184 (elmo-maildir-set-mark
185 (elmo-maildir-message-file-name folder location)
187 ;; Append to flagged location list.
188 (elmo-maildir-folder-set-flagged-locations-internal
191 (elmo-maildir-folder-flagged-locations-internal
193 (setq flags (delq 'unread flags)))
194 (when (and (memq 'answered flags)
195 (not (member location answered-list)))
196 (elmo-maildir-set-mark
197 (elmo-maildir-message-file-name folder location)
199 ;; Append to answered location list.
200 (elmo-maildir-folder-set-answered-locations-internal
203 (elmo-maildir-folder-answered-locations-internal folder)))
204 (setq flags (delq 'unread flags)))
205 (when (and (not (memq 'unread flags))
206 (member location unread-list))
207 (elmo-maildir-set-mark
208 (elmo-maildir-message-file-name folder location)
210 ;; Delete from unread locations.
211 (elmo-maildir-folder-set-unread-locations-internal
214 (elmo-maildir-folder-unread-locations-internal
216 (unless (memq 'unread flags)
217 (setq flags (delq 'new flags)))
218 (elmo-global-flags-set flags folder number message-id)
219 (elmo-msgdb-append-entity new-msgdb entity flags)
220 (when (> len elmo-display-progress-threshold)
222 (elmo-display-progress
223 'elmo-maildir-msgdb-create "Creating msgdb..."
224 (/ (* i 100) len)))))
225 (message "Creating msgdb...done")
226 (elmo-msgdb-sort-by-date new-msgdb)))
228 (defun elmo-maildir-cleanup-temporal (dir)
229 ;; Delete files in the tmp dir which are not accessed
230 ;; for more than 36 hours.
231 (let ((cur-time (current-time))
236 (setq last-accessed (nth 4 (file-attributes file)))
237 (when (or (> (- (car cur-time)(car last-accessed)) 1)
238 (and (eq (- (car cur-time)(car last-accessed)) 1)
239 (> (- (cadr cur-time)(cadr last-accessed))
241 (message "Maildir: %d tmp file(s) are cleared."
242 (setq count (1+ count)))
243 (delete-file file))))
244 (directory-files (expand-file-name "tmp" dir)
248 (defun elmo-maildir-update-current (folder)
249 "Move all new msgs to cur in the maildir."
250 (let* ((maildir (elmo-maildir-folder-directory-internal folder))
251 (news (directory-files (expand-file-name "new"
255 ;; cleanup tmp directory.
256 (elmo-maildir-cleanup-temporal maildir)
257 ;; move new msgs to cur directory.
260 (expand-file-name (car news) (expand-file-name "new" maildir))
261 (expand-file-name (concat
263 (unless (string-match ":2,[A-Z]*$" (car news))
265 (expand-file-name "cur" maildir)))
266 (setq news (cdr news)))))
268 (defun elmo-maildir-set-mark (filename mark)
269 "Mark the FILENAME file in the maildir. MARK is a character."
270 (if (string-match "^\\([^:]+:[12],\\)\\(.*\\)$" filename)
271 (let ((flaglist (string-to-char-list (elmo-match-string
273 (unless (memq mark flaglist)
274 (setq flaglist (sort (cons mark flaglist) '<))
275 (rename-file filename
276 (concat (elmo-match-string 1 filename)
277 (char-list-to-string flaglist)))))
278 ;; Rescue no info file in maildir.
279 (rename-file filename
280 (concat filename ":2," (char-to-string mark))))
283 (defun elmo-maildir-delete-mark (filename mark)
284 "Mark the FILENAME file in the maildir. MARK is a character."
285 (if (string-match "^\\([^:]+:2,\\)\\(.*\\)$" filename)
286 (let ((flaglist (string-to-char-list (elmo-match-string
288 (when (memq mark flaglist)
289 (setq flaglist (delq mark flaglist))
290 (rename-file filename
291 (concat (elmo-match-string 1 filename)
293 (char-list-to-string flaglist))))))))
295 (defsubst elmo-maildir-set-mark-msgs (folder locs mark)
297 (elmo-maildir-set-mark
298 (elmo-maildir-message-file-name folder loc)
302 (defsubst elmo-maildir-delete-mark-msgs (folder locs mark)
304 (elmo-maildir-delete-mark
305 (elmo-maildir-message-file-name folder loc)
309 (defsubst elmo-maildir-set-mark-messages (folder locations mark remove)
312 (elmo-maildir-delete-mark-msgs folder locations mark)
313 (elmo-maildir-set-mark-msgs folder locations mark))))
315 (luna-define-method elmo-map-folder-set-flag ((folder elmo-maildir-folder)
317 (let ((spec (cdr (assq flag elmo-maildir-flag-specs))))
319 (elmo-maildir-set-mark-messages folder locations
320 (car spec) (nth 1 spec)))))
322 (luna-define-method elmo-map-folder-unset-flag ((folder elmo-maildir-folder)
324 (let ((spec (cdr (assq flag elmo-maildir-flag-specs))))
326 (elmo-maildir-set-mark-messages folder locations
327 (car spec) (not (nth 1 spec))))))
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 flags 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))
414 (let* ((path (elmo-folder-msgdb-path folder))
415 (table (elmo-flag-table-load path))
416 (msgid (std11-field-body "message-id")))
418 (elmo-flag-table-set table msgid flags)
419 (elmo-flag-table-save path table)))
421 ;; If an error occured, return nil.
424 (luna-define-method elmo-folder-message-file-p ((folder elmo-maildir-folder))
427 (luna-define-method elmo-message-file-name ((folder elmo-maildir-folder)
429 (elmo-maildir-message-file-name
431 (elmo-map-message-location folder number)))
433 (luna-define-method elmo-folder-message-make-temp-file-p
434 ((folder elmo-maildir-folder))
437 (luna-define-method elmo-folder-message-make-temp-files ((folder
442 (let ((temp-dir (elmo-folder-make-temporary-directory folder))
443 (cur-number (if start-number 0)))
444 (dolist (number numbers)
446 (elmo-message-file-name folder number)
448 (int-to-string (if start-number (incf cur-number) number))
452 (luna-define-method elmo-folder-append-messages :around
453 ((folder elmo-maildir-folder)
454 src-folder numbers &optional same-number)
455 (if (elmo-folder-message-file-p src-folder)
456 (let ((src-msgdb-exists (not (zerop (elmo-folder-length src-folder))))
457 (dir (elmo-maildir-folder-directory-internal folder))
458 (table (elmo-flag-table-load (elmo-folder-msgdb-path folder)))
461 (dolist (number numbers)
462 (setq flags (elmo-message-flags src-folder (car numbers))
463 filename (elmo-maildir-temporal-filename dir))
465 (elmo-message-file-name src-folder number)
467 (elmo-add-name-to-file
470 (concat "new/" (file-name-nondirectory filename))
472 ;; src folder's msgdb is loaded.
473 (when (setq id (and src-msgdb-exists
474 (elmo-message-field src-folder (car numbers)
476 (elmo-flag-table-set table id flags))
477 (elmo-progress-notify 'elmo-folder-move-messages))
478 (when (elmo-folder-persistent-p folder)
479 (elmo-flag-table-save (elmo-folder-msgdb-path folder) table))
481 (luna-call-next-method)))
483 (luna-define-method elmo-map-folder-delete-messages
484 ((folder elmo-maildir-folder) locations)
486 (dolist (location locations)
487 (setq file (elmo-maildir-message-file-name folder location))
489 (file-writable-p file)
490 (not (file-directory-p file)))
491 (delete-file file)))))
493 (luna-define-method elmo-map-message-fetch ((folder elmo-maildir-folder)
495 &optional section unseen)
496 (let ((file (elmo-maildir-message-file-name folder location)))
497 (when (file-exists-p file)
498 (insert-file-contents-as-binary file))))
500 (luna-define-method elmo-folder-exists-p ((folder elmo-maildir-folder))
501 (let ((basedir (elmo-maildir-folder-directory-internal folder)))
502 (and (file-directory-p (expand-file-name "new" basedir))
503 (file-directory-p (expand-file-name "cur" basedir))
504 (file-directory-p (expand-file-name "tmp" basedir)))))
506 (luna-define-method elmo-folder-diff ((folder elmo-maildir-folder))
507 (let* ((dir (elmo-maildir-folder-directory-internal folder))
508 (new-len (length (car (elmo-maildir-list-location dir "new"))))
509 (cur-len (length (car (elmo-maildir-list-location dir "cur")))))
510 (cons new-len (+ new-len cur-len))))
512 (luna-define-method elmo-folder-creatable-p ((folder elmo-maildir-folder))
515 (luna-define-method elmo-folder-writable-p ((folder elmo-maildir-folder))
518 (luna-define-method elmo-folder-create ((folder elmo-maildir-folder))
519 (let ((basedir (elmo-maildir-folder-directory-internal folder)))
522 (dolist (dir '("." "new" "cur" "tmp"))
523 (setq dir (expand-file-name dir basedir))
524 (or (file-directory-p dir)
526 (elmo-make-directory dir)
527 (set-file-modes dir 448))))
531 (luna-define-method elmo-folder-delete ((folder elmo-maildir-folder))
532 (let ((msgs (and (elmo-folder-exists-p folder)
533 (elmo-folder-list-messages folder))))
534 (when (yes-or-no-p (format "%sDelete msgdb and substance of \"%s\"? "
535 (if (> (length msgs) 0)
536 (format "%d msg(s) exists. " (length msgs))
538 (elmo-folder-name-internal folder)))
539 (let ((basedir (elmo-maildir-folder-directory-internal folder)))
541 (let ((tmp-files (directory-files
542 (expand-file-name "tmp" basedir)
544 ;; Delete files in tmp.
545 (dolist (file tmp-files)
547 (dolist (dir '("new" "cur" "tmp" "."))
548 (setq dir (expand-file-name dir basedir))
549 (if (not (file-directory-p dir))
551 (elmo-delete-directory dir t))))
553 (elmo-msgdb-delete-path folder)
556 (luna-define-method elmo-folder-rename-internal ((folder elmo-maildir-folder)
558 (let* ((old (elmo-maildir-folder-directory-internal folder))
559 (new (elmo-maildir-folder-directory-internal new-folder))
560 (new-dir (directory-file-name (file-name-directory new))))
561 (unless (file-directory-p old)
562 (error "No such directory: %s" old))
563 (when (file-exists-p new)
564 (error "Already exists directory: %s" new))
565 (unless (file-directory-p new-dir)
566 (elmo-make-directory new-dir))
567 (rename-file old new)
571 (product-provide (provide 'elmo-maildir) (require 'elmo-version))
573 ;;; elmo-maildir.el ends here