Use elmo-imap4-list in elmo-imap4-folder-list-flagged
[more-wl.git] / elmo / elmo-maildir.el
blobc2367706e4fca8499f3aa6b0964b4a0e5772ccf8
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)
13 ;; any later version.
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.
26 ;;; Commentary:
29 ;;; Code:
32 (eval-when-compile (require 'cl))
34 (require 'elmo-util)
35 (require 'elmo)
36 (require 'elmo-map)
38 (defcustom elmo-maildir-folder-path "~/Maildir"
39 "*Maildir folder path."
40 :type 'directory
41 :group 'elmo)
43 (defconst elmo-maildir-flag-specs '((important ?F)
44 (read ?S)
45 (unread ?S 'remove)
46 (answered ?R)))
48 (defcustom elmo-maildir-separator
49 (if (memq system-type
50 '(windows-nt OS/2 emx ms-dos win32 w32 mswindows cygwin))
51 ?\- ?:)
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."
55 :type 'character
56 :group 'elmo)
58 (defmacro elmo-maildir-adjust-separator (string)
59 `(if (= elmo-maildir-separator ?:)
60 ,string
61 (elmo-replace-in-string
62 ,string ":" (char-to-string elmo-maildir-separator))))
64 ;;; ELMO Maildir folder
65 (eval-and-compile
66 (luna-define-class elmo-maildir-folder
67 (elmo-map-folder elmo-file-tag)
68 (directory unread-locations
69 flagged-locations
70 answered-locations))
71 (luna-define-internal-accessors 'elmo-maildir-folder))
73 (luna-define-method elmo-folder-initialize ((folder
74 elmo-maildir-folder)
75 name)
76 (if (file-name-absolute-p name)
77 (elmo-maildir-folder-set-directory-internal
78 folder
79 (expand-file-name name))
80 (elmo-maildir-folder-set-directory-internal
81 folder
82 (expand-file-name
83 name
84 elmo-maildir-folder-path)))
85 folder)
87 (luna-define-method elmo-folder-expand-msgdb-path ((folder
88 elmo-maildir-folder))
89 (expand-file-name
90 (elmo-replace-string-as-filename
91 (elmo-maildir-folder-directory-internal folder))
92 (expand-file-name
93 "maildir"
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
98 LOCATION."
99 (let ((file (file-name-completion
100 location
101 (expand-file-name
102 "cur"
103 (elmo-maildir-folder-directory-internal folder)))))
104 (if file
105 (expand-file-name
106 (if (eq file t) location file)
107 (expand-file-name
108 "cur"
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
117 nil "^[^.].*$" t)))
118 (regexp (elmo-maildir-adjust-separator "^\\(.+\\):[12],\\(.*\\)$"))
119 unread-locations flagged-locations answered-locations
120 sym locations flag-list x-time y-time)
121 (setq cur (sort cur
122 (lambda (x y)
123 (setq x-time (cdr x)
124 y-time (cdr y))
125 (cond
126 ((< x-time y-time)
128 ((eq x-time y-time)
129 (< (elmo-maildir-sequence-number (car x))
130 (elmo-maildir-sequence-number (car y))))))))
131 (setq locations
132 (mapcar
133 (lambda (x)
134 (let ((name (car x)))
135 (if (string-match regexp name)
136 (progn
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)))
149 sym)
150 name)))
151 cur))
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))
163 (nth 0 locs)))
165 (luna-define-method elmo-map-folder-list-flagged ((folder elmo-maildir-folder)
166 flag)
167 (case flag
168 (unread
169 (elmo-maildir-folder-unread-locations-internal folder))
170 (important
171 (elmo-maildir-folder-flagged-locations-internal folder))
172 (answered
173 (elmo-maildir-folder-answered-locations-internal folder))
174 (otherwise
175 t)))
177 (luna-define-method elmo-folder-msgdb-create ((folder elmo-maildir-folder)
178 numbers flag-table)
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
182 folder))
183 (new-msgdb (elmo-make-msgdb))
184 entity message-id flags location)
185 (elmo-with-progress-display (elmo-folder-msgdb-create (length numbers))
186 "Creating msgdb"
187 (dolist (number numbers)
188 (setq location (elmo-map-message-location folder number))
189 (setq entity
190 (elmo-msgdb-create-message-entity-from-file
191 (elmo-msgdb-message-entity-handler new-msgdb)
192 number
193 (elmo-maildir-message-file-name folder location)))
194 (when entity
195 (setq message-id (elmo-message-entity-field entity 'message-id)
196 ;; Precede flag-table to file-info.
197 flags (copy-sequence
198 (elmo-flag-table-get flag-table message-id)))
200 ;; Already flagged on filename (precede it to flag-table).
201 (when (member location flagged-list)
202 (or (memq 'important flags)
203 (setq flags (cons 'important flags))))
204 (when (member location answered-list)
205 (or (memq 'answered flags)
206 (setq flags (cons 'answered flags))))
207 (unless (member location unread-list)
208 (and (memq 'unread flags)
209 (setq flags (delq 'unread flags))))
211 ;; Update filename's info portion according to the flag-table.
212 (when (and (memq 'important flags)
213 (not (member location flagged-list)))
214 (elmo-maildir-set-mark
215 (elmo-maildir-message-file-name folder location)
217 ;; Append to flagged location list.
218 (elmo-maildir-folder-set-flagged-locations-internal
219 folder
220 (cons location
221 (elmo-maildir-folder-flagged-locations-internal
222 folder)))
223 (setq flags (delq 'unread flags)))
224 (when (and (memq 'answered flags)
225 (not (member location answered-list)))
226 (elmo-maildir-set-mark
227 (elmo-maildir-message-file-name folder location)
229 ;; Append to answered location list.
230 (elmo-maildir-folder-set-answered-locations-internal
231 folder
232 (cons location
233 (elmo-maildir-folder-answered-locations-internal folder)))
234 (setq flags (delq 'unread flags)))
235 (when (and (not (memq 'unread flags))
236 (member location unread-list))
237 (elmo-maildir-set-mark
238 (elmo-maildir-message-file-name folder location)
240 ;; Delete from unread locations.
241 (elmo-maildir-folder-set-unread-locations-internal
242 folder
243 (delete location
244 (elmo-maildir-folder-unread-locations-internal
245 folder))))
246 (unless (memq 'unread flags)
247 (setq flags (delq 'new flags)))
248 (elmo-global-flags-set flags folder number message-id)
249 (elmo-msgdb-append-entity new-msgdb entity flags))
250 (elmo-progress-notify 'elmo-folder-msgdb-create)))
251 new-msgdb))
253 (defun elmo-maildir-cleanup-temporal (dir)
254 ;; Delete files in the tmp dir which are not accessed
255 ;; for more than 36 hours.
256 (let ((cur-time (current-time))
257 (count 0)
258 last-accessed)
259 (mapcar (function
260 (lambda (file)
261 (setq last-accessed (nth 4 (file-attributes file)))
262 (when (or (> (- (car cur-time)(car last-accessed)) 1)
263 (and (eq (- (car cur-time)(car last-accessed)) 1)
264 (> (- (cadr cur-time)(cadr last-accessed))
265 64064))) ; 36 hours.
266 (message "Maildir: %d tmp file(s) are cleared."
267 (setq count (1+ count)))
268 (delete-file file))))
269 (directory-files (expand-file-name "tmp" dir)
270 t ; full
271 "^[^.].*$" t))))
273 (defun elmo-maildir-update-current (folder)
274 "Move all new msgs to cur in the maildir."
275 (let* ((maildir (elmo-maildir-folder-directory-internal folder))
276 (news (directory-files (expand-file-name "new"
277 maildir)
279 "^[^.].*$" t)))
280 ;; cleanup tmp directory.
281 (elmo-maildir-cleanup-temporal maildir)
282 ;; move new msgs to cur directory.
283 (while news
284 (rename-file
285 (expand-file-name (car news) (expand-file-name "new" maildir))
286 (expand-file-name (concat
287 (car news)
288 (unless (string-match
289 (elmo-maildir-adjust-separator ":2,[A-Z]*$")
290 (car news))
291 (elmo-maildir-adjust-separator ":2,")))
292 (expand-file-name "cur" maildir)))
293 (setq news (cdr news)))))
295 (defun elmo-maildir-set-mark (filename mark)
296 "Mark the FILENAME file in the maildir. MARK is a character."
297 (if (string-match
298 (elmo-maildir-adjust-separator "^\\(.+:[12],\\)\\(.*\\)$")
299 filename)
300 (let ((flaglist (string-to-char-list (elmo-match-string
301 2 filename))))
302 (unless (memq mark flaglist)
303 (setq flaglist (sort (cons mark flaglist) '<))
304 (rename-file filename
305 (concat (elmo-match-string 1 filename)
306 (char-list-to-string flaglist)))))
307 ;; Rescue no info file in maildir.
308 (rename-file filename
309 (concat filename
310 (elmo-maildir-adjust-separator ":2,")
311 (char-to-string mark))))
314 (defun elmo-maildir-delete-mark (filename mark)
315 "Mark the FILENAME file in the maildir. MARK is a character."
316 (if (string-match (elmo-maildir-adjust-separator "^\\(.+:2,\\)\\(.*\\)$")
317 filename)
318 (let ((flaglist (string-to-char-list (elmo-match-string
319 2 filename))))
320 (when (memq mark flaglist)
321 (setq flaglist (delq mark flaglist))
322 (rename-file filename
323 (concat (elmo-match-string 1 filename)
324 (if flaglist
325 (char-list-to-string flaglist))))))))
327 (defsubst elmo-maildir-set-mark-msgs (folder locs mark)
328 (dolist (loc locs)
329 (elmo-maildir-set-mark
330 (elmo-maildir-message-file-name folder loc)
331 mark))
334 (defsubst elmo-maildir-delete-mark-msgs (folder locs mark)
335 (dolist (loc locs)
336 (elmo-maildir-delete-mark
337 (elmo-maildir-message-file-name folder loc)
338 mark))
341 (defsubst elmo-maildir-set-mark-messages (folder locations mark remove)
342 (when mark
343 (if remove
344 (elmo-maildir-delete-mark-msgs folder locations mark)
345 (elmo-maildir-set-mark-msgs folder locations mark))))
347 (luna-define-method elmo-map-folder-set-flag ((folder elmo-maildir-folder)
348 locations flag)
349 (let ((spec (cdr (assq flag elmo-maildir-flag-specs))))
350 (when spec
351 (elmo-maildir-set-mark-messages folder locations
352 (car spec) (nth 1 spec)))))
354 (luna-define-method elmo-map-folder-unset-flag ((folder elmo-maildir-folder)
355 locations flag)
356 (let ((spec (cdr (assq flag elmo-maildir-flag-specs))))
357 (when spec
358 (elmo-maildir-set-mark-messages folder locations
359 (car spec) (not (nth 1 spec))))))
361 (luna-define-method elmo-folder-list-subfolders
362 ((folder elmo-maildir-folder) &optional one-level)
363 (let ((prefix (concat (elmo-folder-name-internal folder)
364 (unless (string= (elmo-folder-prefix-internal folder)
365 (elmo-folder-name-internal folder))
366 elmo-path-sep)))
367 (elmo-list-subdirectories-ignore-regexp
368 "^\\(\\.\\.?\\|cur\\|tmp\\|new\\)$")
369 elmo-have-link-count)
370 (append
371 (list (elmo-folder-name-internal folder))
372 (elmo-mapcar-list-of-list
373 (function (lambda (x) (concat prefix x)))
374 (elmo-list-subdirectories
375 (elmo-maildir-folder-directory-internal folder)
377 one-level)))))
379 (defvar elmo-maildir-sequence-number-internal 0)
381 (defun elmo-maildir-sequence-number (file)
382 "Get `elmo-maildir' specific sequence number from FILE.
383 Not that FILE is the name without directory."
384 ;; elmo-maildir specific.
385 (if (string-match "^.*_\\([0-9]+\\)\\..*" file)
386 (string-to-number (match-string 1 file))
387 -1))
389 (defun elmo-maildir-make-unique-string ()
390 "This function generates a string that can be used as a unique
391 file name for maildir directories."
392 (let ((cur-time (current-time)))
393 (format "%.0f.%d_%d.%s"
394 (+ (* (car cur-time)
395 (float 65536)) (cadr cur-time))
396 (emacs-pid)
397 (incf elmo-maildir-sequence-number-internal)
398 (system-name))))
400 (defun elmo-maildir-temporal-filename (basedir)
401 (let ((filename (expand-file-name
402 (concat "tmp/" (elmo-maildir-make-unique-string))
403 basedir)))
404 (unless (file-exists-p (file-name-directory filename))
405 (make-directory (file-name-directory filename)))
406 (while (file-exists-p filename)
407 ;;; I don't want to wait.
408 ;;; (sleep-for 2)
409 (setq filename
410 (expand-file-name
411 (concat "tmp/" (elmo-maildir-make-unique-string))
412 basedir)))
413 filename))
415 (defun elmo-maildir-move-file (src dst)
416 (or (condition-case nil
417 (progn
418 ;; 1. Try add-link-to-file, then delete the original.
419 ;; This is safe on NFS.
420 (add-name-to-file src dst)
421 (ignore-errors
422 ;; It's ok if the delete-file fails;
423 ;; elmo-maildir-cleanup-temporal will catch it later.
424 (delete-file src))
426 (error))
427 ;; 2. Even on systems with hardlinks, some filesystems (like AFS)
428 ;; might not support them, so fall back on rename-file. This is
429 ;; our best shot at atomic when add-name-to-file fails.
430 (rename-file src dst)))
432 (luna-define-method elmo-folder-append-buffer ((folder elmo-maildir-folder)
433 &optional flags number)
434 (let ((basedir (elmo-maildir-folder-directory-internal folder))
435 (src-buf (current-buffer))
436 dst-buf filename)
437 (condition-case nil
438 (with-temp-buffer
439 (setq filename (elmo-maildir-temporal-filename basedir))
440 (setq dst-buf (current-buffer))
441 (with-current-buffer src-buf
442 (copy-to-buffer dst-buf (point-min) (point-max)))
443 (as-binary-output-file
444 (write-region (point-min) (point-max) filename nil 'no-msg))
445 (elmo-maildir-move-file
446 filename
447 (expand-file-name
448 (concat "new/" (file-name-nondirectory filename))
449 basedir))
450 (elmo-folder-preserve-flags
451 folder (elmo-msgdb-get-message-id-from-buffer) flags)
453 ;; If an error occured, return nil.
454 (error))))
456 (luna-define-method elmo-folder-message-file-p ((folder elmo-maildir-folder))
459 (luna-define-method elmo-message-file-name ((folder elmo-maildir-folder)
460 number)
461 (elmo-maildir-message-file-name
462 folder
463 (elmo-map-message-location folder number)))
465 (luna-define-method elmo-folder-message-make-temp-file-p
466 ((folder elmo-maildir-folder))
469 (luna-define-method elmo-folder-message-make-temp-files ((folder
470 elmo-maildir-folder)
471 numbers
472 &optional
473 start-number)
474 (let ((temp-dir (elmo-folder-make-temporary-directory folder))
475 (cur-number (or start-number 0)))
476 (dolist (number numbers)
477 (elmo-copy-file
478 (elmo-message-file-name folder number)
479 (expand-file-name
480 (int-to-string (if start-number cur-number number))
481 temp-dir))
482 (incf cur-number))
483 temp-dir))
485 (defun elmo-folder-append-messages-*-maildir (folder
486 src-folder
487 numbers
488 same-number)
489 (let ((src-msgdb-exists (not (zerop (elmo-folder-length src-folder))))
490 (dir (elmo-maildir-folder-directory-internal folder))
491 (table (elmo-folder-flag-table folder))
492 (succeeds numbers)
493 filename flags id)
494 (dolist (number numbers)
495 (setq flags (elmo-message-flags src-folder number)
496 filename (elmo-maildir-temporal-filename dir))
497 (elmo-copy-file
498 (elmo-message-file-name src-folder number)
499 filename)
500 (elmo-maildir-move-file
501 filename
502 (expand-file-name
503 (concat "new/" (file-name-nondirectory filename))
504 dir))
505 ;; src folder's msgdb is loaded.
506 (when (setq id (and src-msgdb-exists
507 (elmo-message-field src-folder number
508 'message-id)))
509 (elmo-flag-table-set table id flags))
510 (elmo-progress-notify 'elmo-folder-move-messages))
511 (when (elmo-folder-persistent-p folder)
512 (elmo-folder-close-flag-table folder))
513 succeeds))
515 (luna-define-method elmo-map-folder-delete-messages
516 ((folder elmo-maildir-folder) locations)
517 (let (file)
518 (dolist (location locations)
519 (setq file (elmo-maildir-message-file-name folder location))
520 (if (and file
521 (file-writable-p file)
522 (not (file-directory-p file)))
523 (delete-file file))))
526 (luna-define-method elmo-map-message-fetch ((folder elmo-maildir-folder)
527 location strategy
528 &optional section unseen)
529 (let ((file (elmo-maildir-message-file-name folder location)))
530 (when (file-exists-p file)
531 (insert-file-contents-as-raw-text file)
532 (unless unseen
533 (elmo-map-folder-set-flag folder (list location) 'read))
534 t)))
536 (luna-define-method elmo-folder-exists-p ((folder elmo-maildir-folder))
537 (let ((basedir (elmo-maildir-folder-directory-internal folder)))
538 (and (file-directory-p (expand-file-name "new" basedir))
539 (file-directory-p (expand-file-name "cur" basedir))
540 (file-directory-p (expand-file-name "tmp" basedir)))))
542 (luna-define-method elmo-folder-diff ((folder elmo-maildir-folder))
543 (let* ((dir (elmo-maildir-folder-directory-internal folder))
544 (new-len (length (car (elmo-maildir-list-location dir "new"))))
545 (cur-len (length (car (elmo-maildir-list-location dir "cur")))))
546 (cons new-len (+ new-len cur-len))))
548 (luna-define-method elmo-folder-creatable-p ((folder elmo-maildir-folder))
551 (luna-define-method elmo-folder-writable-p ((folder elmo-maildir-folder))
554 (luna-define-method elmo-folder-create ((folder elmo-maildir-folder))
555 (let ((basedir (elmo-maildir-folder-directory-internal folder)))
556 (condition-case nil
557 (progn
558 (dolist (dir '("." "new" "cur" "tmp"))
559 (setq dir (expand-file-name dir basedir))
560 (or (file-directory-p dir)
561 (progn
562 (elmo-make-directory dir)
563 (set-file-modes dir 448))))
565 (error))))
567 (luna-define-method elmo-folder-delete ((folder elmo-maildir-folder))
568 (let ((msgs (and (elmo-folder-exists-p folder)
569 (elmo-folder-list-messages folder))))
570 (when (yes-or-no-p (format "%sDelete msgdb and substance of \"%s\"? "
571 (if (> (length msgs) 0)
572 (format "%d msg(s) exists. " (length msgs))
574 (elmo-folder-name-internal folder)))
575 (let ((basedir (elmo-maildir-folder-directory-internal folder)))
576 (condition-case nil
577 (let ((tmp-files (directory-files
578 (expand-file-name "tmp" basedir)
579 t "[^.].*")))
580 ;; Delete files in tmp.
581 (dolist (file tmp-files)
582 (delete-file file))
583 (dolist (dir '("new" "cur" "tmp" "."))
584 (setq dir (expand-file-name dir basedir))
585 (if (not (file-directory-p dir))
586 (error nil)
587 (elmo-delete-directory dir t))))
588 (error nil)))
589 (elmo-msgdb-delete-path folder)
590 t)))
592 (luna-define-method elmo-folder-rename-internal ((folder elmo-maildir-folder)
593 new-folder)
594 (let* ((old (elmo-maildir-folder-directory-internal folder))
595 (new (elmo-maildir-folder-directory-internal new-folder))
596 (new-dir (directory-file-name (file-name-directory new))))
597 (unless (file-directory-p old)
598 (error "No such directory: %s" old))
599 (when (file-exists-p new)
600 (error "Already exists directory: %s" new))
601 (unless (file-directory-p new-dir)
602 (elmo-make-directory new-dir))
603 (rename-file old new)
606 (require 'product)
607 (product-provide (provide 'elmo-maildir) (require 'elmo-version))
609 ;;; elmo-maildir.el ends here