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 flagged-locations))
48 (luna-define-internal-accessors 'elmo-maildir-folder))
50 (luna-define-method elmo-folder-initialize ((folder
53 (if (file-name-absolute-p name)
54 (elmo-maildir-folder-set-directory-internal
56 (expand-file-name name))
57 (elmo-maildir-folder-set-directory-internal
61 elmo-maildir-folder-path)))
64 (luna-define-method elmo-folder-expand-msgdb-path ((folder
67 (elmo-replace-string-as-filename
68 (elmo-maildir-folder-directory-internal folder))
71 elmo-msgdb-directory)))
73 (defun elmo-maildir-message-file-name (folder location)
74 "Get a file name of the message from FOLDER which corresponded to
76 (let ((file (file-name-completion
80 (elmo-maildir-folder-directory-internal folder)))))
83 (if (eq file t) location file)
86 (elmo-maildir-folder-directory-internal folder))))))
88 (defsubst elmo-maildir-list-location (dir &optional child-dir)
89 (let* ((cur-dir (expand-file-name (or child-dir "cur") dir))
90 (cur (directory-files cur-dir
92 unread-locations flagged-locations seen flagged sym
97 (if (string-match "^\\([^:]+\\):\\([^:]+\\)$" x)
102 ((string-match "S" (elmo-match-string 2 x))
104 ((string-match "F" (elmo-match-string 2 x))
106 (setq sym (elmo-match-string 1 x))
107 (unless seen (setq unread-locations
108 (cons sym unread-locations)))
109 (if flagged (setq flagged-locations
110 (cons sym flagged-locations)))
114 (list locations unread-locations flagged-locations)))
116 (luna-define-method elmo-map-folder-list-message-locations
117 ((folder elmo-maildir-folder))
118 (elmo-maildir-update-current folder)
119 (let ((locs (elmo-maildir-list-location
120 (elmo-maildir-folder-directory-internal folder))))
121 ;; 0: locations, 1: unread-locations, 2: flagged-locations
122 (elmo-maildir-folder-set-unread-locations-internal folder (nth 1 locs))
123 (elmo-maildir-folder-set-flagged-locations-internal folder (nth 2 locs))
126 (luna-define-method elmo-map-folder-list-unreads
127 ((folder elmo-maildir-folder))
128 (elmo-maildir-folder-unread-locations-internal folder))
130 (luna-define-method elmo-map-folder-list-importants
131 ((folder elmo-maildir-folder))
132 (elmo-maildir-folder-flagged-locations-internal folder))
134 (luna-define-method elmo-folder-msgdb-create
135 ((folder elmo-maildir-folder) numbers flag-table)
136 (let* ((unread-list (elmo-maildir-folder-unread-locations-internal folder))
137 (flagged-list (elmo-maildir-folder-flagged-locations-internal folder))
138 (len (length numbers))
140 overview number-alist mark-alist entity
142 (message "Creating msgdb...")
145 (setq location (elmo-map-message-location folder number))
147 (elmo-msgdb-create-overview-entity-from-file
149 (elmo-maildir-message-file-name folder location)))
152 (elmo-msgdb-append-element overview entity))
154 (elmo-msgdb-number-add number-alist
155 (elmo-msgdb-overview-entity-get-number
157 (elmo-msgdb-overview-entity-get-id
160 ((member location unread-list)
161 (setq mark elmo-msgdb-new-mark)) ; unread!
162 ((member location flagged-list)
163 (setq mark elmo-msgdb-important-mark)))
164 (if (setq mark (or (elmo-msgdb-global-mark-get
165 (elmo-msgdb-overview-entity-get-id
169 (elmo-msgdb-mark-append
171 (elmo-msgdb-overview-entity-get-number
174 (when (> len elmo-display-progress-threshold)
176 (elmo-display-progress
177 'elmo-maildir-msgdb-create "Creating msgdb..."
178 (/ (* i 100) len)))))
179 (message "Creating msgdb...done")
180 (elmo-msgdb-sort-by-date
181 (list overview number-alist mark-alist))))
183 (defun elmo-maildir-cleanup-temporal (dir)
184 ;; Delete files in the tmp dir which are not accessed
185 ;; for more than 36 hours.
186 (let ((cur-time (current-time))
191 (setq last-accessed (nth 4 (file-attributes file)))
192 (when (or (> (- (car cur-time)(car last-accessed)) 1)
193 (and (eq (- (car cur-time)(car last-accessed)) 1)
194 (> (- (cadr cur-time)(cadr last-accessed))
196 (message "Maildir: %d tmp file(s) are cleared."
197 (setq count (1+ count)))
198 (delete-file file))))
199 (directory-files (expand-file-name "tmp" dir)
203 (defun elmo-maildir-update-current (folder)
204 "Move all new msgs to cur in the maildir."
205 (let* ((maildir (elmo-maildir-folder-directory-internal folder))
206 (news (directory-files (expand-file-name "new"
210 ;; cleanup tmp directory.
211 (elmo-maildir-cleanup-temporal maildir)
212 ;; move new msgs to cur directory.
215 (expand-file-name (car news) (expand-file-name "new" maildir))
216 (expand-file-name (concat
218 (unless (string-match ":2,[A-Z]*$" (car news))
220 (expand-file-name "cur" maildir)))
221 (setq news (cdr news)))))
223 (defun elmo-maildir-set-mark (filename mark)
224 "Mark the FILENAME file in the maildir. MARK is a character."
225 (if (string-match "^\\([^:]+:[12],\\)\\(.*\\)$" filename)
226 (let ((flaglist (string-to-char-list (elmo-match-string
228 (unless (memq mark flaglist)
229 (setq flaglist (sort (cons mark flaglist) '<))
230 (rename-file filename
231 (concat (elmo-match-string 1 filename)
232 (char-list-to-string flaglist)))))
233 ;; Rescue no info file in maildir.
234 (rename-file filename
235 (concat filename ":2," (char-to-string mark))))
238 (defun elmo-maildir-delete-mark (filename mark)
239 "Mark the FILENAME file in the maildir. MARK is a character."
240 (if (string-match "^\\([^:]+:2,\\)\\(.*\\)$" filename)
241 (let ((flaglist (string-to-char-list (elmo-match-string
243 (when (memq mark flaglist)
244 (setq flaglist (delq mark flaglist))
245 (rename-file filename
246 (concat (elmo-match-string 1 filename)
248 (char-list-to-string flaglist))))))))
250 (defsubst elmo-maildir-set-mark-msgs (folder locs mark)
252 (elmo-maildir-set-mark
253 (elmo-maildir-message-file-name folder loc)
257 (defsubst elmo-maildir-delete-mark-msgs (folder locs mark)
259 (elmo-maildir-delete-mark
260 (elmo-maildir-message-file-name folder loc)
264 (luna-define-method elmo-map-folder-mark-as-important ((folder elmo-maildir-folder)
266 (elmo-maildir-set-mark-msgs folder locs ?F))
268 (luna-define-method elmo-map-folder-unmark-important ((folder elmo-maildir-folder)
270 (elmo-maildir-delete-mark-msgs folder locs ?F))
272 (luna-define-method elmo-map-folder-mark-as-read ((folder elmo-maildir-folder)
274 (elmo-maildir-set-mark-msgs folder locs ?S))
276 (luna-define-method elmo-map-folder-unmark-read ((folder elmo-maildir-folder)
278 (elmo-maildir-delete-mark-msgs folder locs ?S))
280 (luna-define-method elmo-map-folder-mark-as-answered ((folder
283 (elmo-maildir-set-mark-msgs folder locs ?R))
285 (luna-define-method elmo-map-folder-unmark-answered ((folder
288 (elmo-maildir-delete-mark-msgs folder locs ?R))
290 (luna-define-method elmo-folder-list-subfolders
291 ((folder elmo-maildir-folder) &optional one-level)
292 (let ((prefix (concat (elmo-folder-name-internal folder)
293 (unless (string= (elmo-folder-prefix-internal folder)
294 (elmo-folder-name-internal folder))
296 (elmo-list-subdirectories-ignore-regexp
297 "^\\(\\.\\.?\\|cur\\|tmp\\|new\\)$")
298 elmo-have-link-count)
300 (list (elmo-folder-name-internal folder))
301 (elmo-mapcar-list-of-list
302 (function (lambda (x) (concat prefix x)))
303 (elmo-list-subdirectories
304 (elmo-maildir-folder-directory-internal folder)
308 (defvar elmo-maildir-sequence-number-internal 0)
311 ((>= emacs-major-version 19)
312 (defun elmo-maildir-make-unique-string ()
313 "This function generates a string that can be used as a unique
314 file name for maildir directories."
315 (let ((cur-time (current-time)))
316 (format "%.0f.%d_%d.%s"
318 (float 65536)) (cadr cur-time))
320 (incf elmo-maildir-sequence-number-internal)
322 ((eq emacs-major-version 18)
323 ;; A fake function for v18
324 (defun elmo-maildir-make-unique-string ()
325 "This function generates a string that can be used as a unique
326 file name for maildir directories."
327 (unless (fboundp 'float-to-string)
328 (load-library "float"))
329 (let ((time (current-time)))
333 (f+ (f* (f (car time))
338 (% (abs (random t)) 10000); dummy pid
341 (defun elmo-maildir-temporal-filename (basedir)
342 (let ((filename (expand-file-name
343 (concat "tmp/" (elmo-maildir-make-unique-string))
345 (unless (file-exists-p (file-name-directory filename))
346 (make-directory (file-name-directory filename)))
347 (while (file-exists-p filename)
348 ;;; I don't want to wait.
352 (concat "tmp/" (elmo-maildir-make-unique-string))
356 (luna-define-method elmo-folder-append-buffer ((folder elmo-maildir-folder)
357 &optional status number)
358 (let ((basedir (elmo-maildir-folder-directory-internal folder))
359 (src-buf (current-buffer))
363 (setq filename (elmo-maildir-temporal-filename basedir))
364 (setq dst-buf (current-buffer))
365 (with-current-buffer src-buf
366 (copy-to-buffer dst-buf (point-min) (point-max)))
367 (as-binary-output-file
368 (write-region (point-min) (point-max) filename nil 'no-msg))
369 ;; add link from new.
370 (elmo-add-name-to-file
373 (concat "new/" (file-name-nondirectory filename))
376 ;; If an error occured, return nil.
379 (luna-define-method elmo-folder-message-file-p ((folder elmo-maildir-folder))
382 (luna-define-method elmo-message-file-name ((folder elmo-maildir-folder)
384 (elmo-maildir-message-file-name
386 (elmo-map-message-location folder number)))
388 (luna-define-method elmo-folder-message-make-temp-file-p
389 ((folder elmo-maildir-folder))
392 (luna-define-method elmo-folder-message-make-temp-files ((folder
397 (let ((temp-dir (elmo-folder-make-temporary-directory folder))
398 (cur-number (if start-number 0)))
399 (dolist (number numbers)
401 (elmo-message-file-name folder number)
403 (int-to-string (if start-number (incf cur-number) number))
407 (luna-define-method elmo-folder-append-messages :around
408 ((folder elmo-maildir-folder)
409 src-folder numbers &optional same-number)
410 (if (elmo-folder-message-file-p src-folder)
411 (let ((dir (elmo-maildir-folder-directory-internal folder))
414 (dolist (number numbers)
415 (setq filename (elmo-maildir-temporal-filename dir))
417 (elmo-message-file-name src-folder number)
419 (elmo-add-name-to-file
422 (concat "new/" (file-name-nondirectory filename))
424 (elmo-progress-notify 'elmo-folder-move-messages))
426 (luna-call-next-method)))
428 (luna-define-method elmo-map-folder-delete-messages
429 ((folder elmo-maildir-folder) locations)
431 (dolist (location locations)
432 (setq file (elmo-maildir-message-file-name folder location))
434 (file-writable-p file)
435 (not (file-directory-p file)))
436 (delete-file file)))))
438 (luna-define-method elmo-map-message-fetch ((folder elmo-maildir-folder)
440 &optional section unseen)
441 (let ((file (elmo-maildir-message-file-name folder location)))
442 (when (file-exists-p file)
443 (insert-file-contents-as-binary file))))
445 (luna-define-method elmo-folder-exists-p ((folder elmo-maildir-folder))
446 (let ((basedir (elmo-maildir-folder-directory-internal folder)))
447 (and (file-directory-p (expand-file-name "new" basedir))
448 (file-directory-p (expand-file-name "cur" basedir))
449 (file-directory-p (expand-file-name "tmp" basedir)))))
451 (luna-define-method elmo-folder-diff ((folder elmo-maildir-folder)
453 (let* ((dir (elmo-maildir-folder-directory-internal folder))
454 (new-len (length (car (elmo-maildir-list-location dir "new"))))
455 (cur-len (length (car (elmo-maildir-list-location dir "cur")))))
456 (cons new-len (+ new-len cur-len))))
458 (luna-define-method elmo-folder-creatable-p ((folder elmo-maildir-folder))
461 (luna-define-method elmo-folder-writable-p ((folder elmo-maildir-folder))
464 (luna-define-method elmo-folder-create ((folder elmo-maildir-folder))
465 (let ((basedir (elmo-maildir-folder-directory-internal folder)))
468 (dolist (dir '("." "new" "cur" "tmp"))
469 (setq dir (expand-file-name dir basedir))
470 (or (file-directory-p dir)
472 (elmo-make-directory dir)
473 (set-file-modes dir 448))))
477 (luna-define-method elmo-folder-delete ((folder elmo-maildir-folder))
478 (let ((msgs (and (elmo-folder-exists-p folder)
479 (elmo-folder-list-messages folder))))
480 (when (yes-or-no-p (format "%sDelete msgdb and substance of \"%s\"? "
481 (if (> (length msgs) 0)
482 (format "%d msg(s) exists. " (length msgs))
484 (elmo-folder-name-internal folder)))
485 (let ((basedir (elmo-maildir-folder-directory-internal folder)))
487 (let ((tmp-files (directory-files
488 (expand-file-name "tmp" basedir)
490 ;; Delete files in tmp.
491 (dolist (file tmp-files)
493 (dolist (dir '("new" "cur" "tmp" "."))
494 (setq dir (expand-file-name dir basedir))
495 (if (not (file-directory-p dir))
497 (elmo-delete-directory dir t))))
499 (elmo-msgdb-delete-path folder)
502 (luna-define-method elmo-folder-rename-internal ((folder elmo-maildir-folder)
504 (let* ((old (elmo-maildir-folder-directory-internal folder))
505 (new (elmo-maildir-folder-directory-internal new-folder))
506 (new-dir (directory-file-name (file-name-directory new))))
507 (unless (file-directory-p old)
508 (error "No such directory: %s" old))
509 (when (file-exists-p new)
510 (error "Already exists directory: %s" new))
511 (unless (file-directory-p new-dir)
512 (elmo-make-directory new-dir))
513 (rename-file old new)
517 (product-provide (provide 'elmo-maildir) (require 'elmo-version))
519 ;;; elmo-maildir.el ends here