elmo/elmo-maildir.el

   1 ;;; elmo-maildir.el --- Maildir interface for ELMO.
   2
   3 ;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
   4
   5 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
   6 ;; Keywords: mail, net news
   7
   8 ;; This file is part of ELMO (Elisp Library for Message Orchestration).
   9
  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.
  14 ;;
  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.
  19 ;;
  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.
  24 ;;
  25
  26 ;;; Commentary:
  27 ;;
  28
  29 ;;; Code:
  30 ;;
  31
  32 (eval-when-compile (require 'cl))
  33
  34 (require 'elmo-util)
  35 (require 'elmo)
  36 (require 'elmo-map)
  37
  38 (defcustom elmo-maildir-folder-path "~/Maildir"
  39   "*Maildir folder path."
  40   :type 'directory
  41   :group 'elmo)
  42
  43 (defconst elmo-maildir-flag-specs '((important ?F)
  44                                     (read ?S)
  45                                     (unread ?S 'remove)
  46                                     (answered ?R)))
  47
  48 ;;; ELMO Maildir folder
  49 (eval-and-compile
  50   (luna-define-class elmo-maildir-folder
  51                      (elmo-map-folder)
  52                      (directory unread-locations
  53                                 flagged-locations
  54                                 answered-locations))
  55   (luna-define-internal-accessors 'elmo-maildir-folder))
  56
  57 (luna-define-method elmo-folder-initialize ((folder
  58                                              elmo-maildir-folder)
  59                                             name)
  60   (if (file-name-absolute-p name)
  61       (elmo-maildir-folder-set-directory-internal
  62        folder
  63        (expand-file-name name))
  64     (elmo-maildir-folder-set-directory-internal
  65      folder
  66      (expand-file-name
  67       name
  68       elmo-maildir-folder-path)))
  69   folder)
  70
  71 (luna-define-method elmo-folder-expand-msgdb-path ((folder
  72                                                     elmo-maildir-folder))
  73   (expand-file-name
  74    (elmo-replace-string-as-filename
  75     (elmo-maildir-folder-directory-internal folder))
  76    (expand-file-name
  77     "maildir"
  78     elmo-msgdb-directory)))
  79
  80 (defun elmo-maildir-message-file-name (folder location)
  81   "Get a file name of the message from FOLDER which corresponded to
  82 LOCATION."
  83   (let ((file (file-name-completion
  84                location
  85                (expand-file-name
  86                 "cur"
  87                 (elmo-maildir-folder-directory-internal folder)))))
  88     (if file
  89         (expand-file-name
  90          (if (eq file t) location file)
  91          (expand-file-name
  92           "cur"
  93           (elmo-maildir-folder-directory-internal folder))))))
  94
  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
  98                                nil "^[^.].*$" t))
  99          unread-locations flagged-locations answered-locations
 100          sym locations flag-list)
 101     (setq locations
 102           (mapcar
 103            (lambda (x)
 104              (if (string-match "^\\([^:]+\\):\\([^:]+\\)$" x)
 105                  (progn
 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)))
 118                    sym)
 119                x))
 120            cur))
 121     (list locations unread-locations flagged-locations answered-locations)))
 122
 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))
 132     (nth 0 locs)))
 133
 134 (luna-define-method elmo-map-folder-list-flagged ((folder elmo-maildir-folder)
 135                                                   flag)
 136   (case flag
 137     (unread
 138      (elmo-maildir-folder-unread-locations-internal folder))
 139     (important
 140      (elmo-maildir-folder-flagged-locations-internal folder))
 141     (answered
 142      (elmo-maildir-folder-answered-locations-internal folder))
 143     (otherwise
 144      t)))
 145
 146 (luna-define-method elmo-folder-msgdb-create ((folder elmo-maildir-folder)
 147                                               numbers flag-table)
 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
 151                          folder))
 152          (len (length numbers))
 153          (new-msgdb (elmo-make-msgdb))
 154          (i 0)
 155          entity message-id flags location)
 156     (message "Creating msgdb...")
 157     (dolist (number numbers)
 158       (setq location (elmo-map-message-location folder number))
 159       (setq entity
 160             (elmo-msgdb-create-message-entity-from-file
 161              (elmo-msgdb-message-entity-handler new-msgdb)
 162              number
 163              (elmo-maildir-message-file-name folder location)))
 164       (when entity
 165         (setq message-id (elmo-message-entity-field entity 'message-id)
 166               ;; Precede flag-table to file-info.
 167               flags (copy-sequence
 168                      (elmo-flag-table-get flag-table message-id)))
 169
 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))))
 180
 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)
 186            ?F)
 187           ;; Append to flagged location list.
 188           (elmo-maildir-folder-set-flagged-locations-internal
 189            folder
 190            (cons location
 191                  (elmo-maildir-folder-flagged-locations-internal
 192                   folder)))
 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)
 198            ?R)
 199           ;; Append to answered location list.
 200           (elmo-maildir-folder-set-answered-locations-internal
 201            folder
 202            (cons location
 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)
 209            ?S)
 210           ;; Delete from unread locations.
 211           (elmo-maildir-folder-set-unread-locations-internal
 212            folder
 213            (delete location
 214                    (elmo-maildir-folder-unread-locations-internal
 215                     folder))))
 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)
 221           (setq i (1+ i))
 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)))
 227
 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))
 232         (count 0)
 233         last-accessed)
 234     (mapcar (function
 235              (lambda (file)
 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))
 240                                  64064))) ; 36 hours.
 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)
 245                              t ; full
 246                              "^[^.].*$" t))))
 247
 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"
 252                                                   maildir)
 253                                 nil
 254                                 "^[^.].*$" t)))
 255     ;; cleanup tmp directory.
 256     (elmo-maildir-cleanup-temporal maildir)
 257     ;; move new msgs to cur directory.
 258     (while news
 259       (rename-file
 260        (expand-file-name (car news) (expand-file-name "new" maildir))
 261        (expand-file-name (concat
 262                           (car news)
 263                           (unless (string-match ":2,[A-Z]*$" (car news))
 264                             ":2,"))
 265                          (expand-file-name "cur" maildir)))
 266       (setq news (cdr news)))))
 267
 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
 272                                             2 filename))))
 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))))
 281   t)
 282
 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
 287                                             2 filename))))
 288         (when (memq mark flaglist)
 289           (setq flaglist (delq mark flaglist))
 290           (rename-file filename
 291                        (concat (elmo-match-string 1 filename)
 292                                (if flaglist
 293                                    (char-list-to-string flaglist))))))))
 294
 295 (defsubst elmo-maildir-set-mark-msgs (folder locs mark)
 296   (dolist (loc locs)
 297     (elmo-maildir-set-mark
 298      (elmo-maildir-message-file-name folder loc)
 299      mark))
 300   t)
 301
 302 (defsubst elmo-maildir-delete-mark-msgs (folder locs mark)
 303   (dolist (loc locs)
 304     (elmo-maildir-delete-mark
 305      (elmo-maildir-message-file-name folder loc)
 306      mark))
 307   t)
 308
 309 (defsubst elmo-maildir-set-mark-messages (folder locations mark remove)
 310   (when mark
 311     (if remove
 312         (elmo-maildir-delete-mark-msgs folder locations mark)
 313       (elmo-maildir-set-mark-msgs folder locations mark))))
 314
 315 (luna-define-method elmo-map-folder-set-flag ((folder elmo-maildir-folder)
 316                                               locations flag)
 317   (let ((spec (cdr (assq flag elmo-maildir-flag-specs))))
 318     (when spec
 319       (elmo-maildir-set-mark-messages folder locations
 320                                       (car spec) (nth 1 spec)))))
 321
 322 (luna-define-method elmo-map-folder-unset-flag ((folder elmo-maildir-folder)
 323                                                 locations flag)
 324   (let ((spec (cdr (assq flag elmo-maildir-flag-specs))))
 325     (when spec
 326       (elmo-maildir-set-mark-messages folder locations
 327                                       (car spec) (not (nth 1 spec))))))
 328
 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))
 334                           elmo-path-sep)))
 335         (elmo-list-subdirectories-ignore-regexp
 336          "^\\(\\.\\.?\\|cur\\|tmp\\|new\\)$")
 337         elmo-have-link-count)
 338     (append
 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)
 344        ""
 345        one-level)))))
 346
 347 (defvar elmo-maildir-sequence-number-internal 0)
 348
 349 (static-cond
 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"
 356               (+ (* (car cur-time)
 357                     (float 65536)) (cadr cur-time))
 358               (emacs-pid)
 359               (incf elmo-maildir-sequence-number-internal)
 360               (system-name)))))
 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)))
 369       (format "%s%d.%d.%s"
 370               (substring
 371                (float-to-string
 372                 (f+ (f* (f (car time))
 373                         (f 65536))
 374                     (f (cadr time))))
 375                0 5)
 376               (cadr time)
 377               (% (abs (random t)) 10000); dummy pid
 378               (system-name))))))
 379
 380 (defun elmo-maildir-temporal-filename (basedir)
 381   (let ((filename (expand-file-name
 382                    (concat "tmp/" (elmo-maildir-make-unique-string))
 383                    basedir)))
 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.
 388 ;;;   (sleep-for 2)
 389       (setq filename
 390             (expand-file-name
 391              (concat "tmp/" (elmo-maildir-make-unique-string))
 392              basedir)))
 393     filename))
 394
 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))
 399         dst-buf filename)
 400     (condition-case nil
 401         (with-temp-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
 410            filename
 411            (expand-file-name
 412             (concat "new/" (file-name-nondirectory filename))
 413             basedir))
 414           (elmo-folder-preserve-falgs
 415            folder (elmo-msgdb-get-message-id-from-buffer) flags)
 416           t)
 417       ;; If an error occured, return nil.
 418       (error))))
 419
 420 (luna-define-method elmo-folder-message-file-p ((folder elmo-maildir-folder))
 421   t)
 422
 423 (luna-define-method elmo-message-file-name ((folder elmo-maildir-folder)
 424                                             number)
 425   (elmo-maildir-message-file-name
 426    folder
 427    (elmo-map-message-location folder number)))
 428
 429 (luna-define-method elmo-folder-message-make-temp-file-p
 430   ((folder elmo-maildir-folder))
 431   t)
 432
 433 (luna-define-method elmo-folder-message-make-temp-files ((folder
 434                                                           elmo-maildir-folder)
 435                                                          numbers
 436                                                          &optional
 437                                                          start-number)
 438   (let ((temp-dir (elmo-folder-make-temporary-directory folder))
 439         (cur-number (if start-number 0)))
 440     (dolist (number numbers)
 441       (elmo-copy-file
 442        (elmo-message-file-name folder number)
 443        (expand-file-name
 444         (int-to-string (if start-number (incf cur-number) number))
 445         temp-dir)))
 446     temp-dir))
 447
 448 (luna-define-method elmo-folder-append-messages :around
 449   ((folder elmo-maildir-folder)
 450    src-folder numbers &optional same-number)
 451   (if (elmo-folder-message-file-p src-folder)
 452       (let ((src-msgdb-exists (not (zerop (elmo-folder-length src-folder))))
 453             (dir (elmo-maildir-folder-directory-internal folder))
 454             (table (elmo-folder-flag-table folder))
 455             (succeeds numbers)
 456             filename flags id)
 457         (dolist (number numbers)
 458           (setq flags (elmo-message-flags src-folder (car numbers))
 459                 filename (elmo-maildir-temporal-filename dir))
 460           (elmo-copy-file
 461            (elmo-message-file-name src-folder number)
 462            filename)
 463           (elmo-add-name-to-file
 464            filename
 465            (expand-file-name
 466             (concat "new/" (file-name-nondirectory filename))
 467             dir))
 468           ;; src folder's msgdb is loaded.
 469           (when (setq id (and src-msgdb-exists
 470                               (elmo-message-field src-folder (car numbers)
 471                                                   'message-id)))
 472             (elmo-flag-table-set table id flags))
 473           (elmo-progress-notify 'elmo-folder-move-messages))
 474         (when (elmo-folder-persistent-p folder)
 475           (elmo-folder-close-flag-table folder))
 476         succeeds)
 477     (luna-call-next-method)))
 478
 479 (luna-define-method elmo-map-folder-delete-messages
 480   ((folder elmo-maildir-folder) locations)
 481   (let (file)
 482     (dolist (location locations)
 483       (setq file (elmo-maildir-message-file-name folder location))
 484       (if (and file
 485                (file-writable-p file)
 486                (not (file-directory-p file)))
 487           (delete-file file)))))
 488
 489 (luna-define-method elmo-map-message-fetch ((folder elmo-maildir-folder)
 490                                             location strategy
 491                                             &optional section unseen)
 492   (let ((file (elmo-maildir-message-file-name folder location)))
 493     (when (file-exists-p file)
 494       (insert-file-contents-as-binary file))))
 495
 496 (luna-define-method elmo-folder-exists-p ((folder elmo-maildir-folder))
 497   (let ((basedir (elmo-maildir-folder-directory-internal folder)))
 498     (and (file-directory-p (expand-file-name "new" basedir))
 499          (file-directory-p (expand-file-name "cur" basedir))
 500          (file-directory-p (expand-file-name "tmp" basedir)))))
 501
 502 (luna-define-method elmo-folder-diff ((folder elmo-maildir-folder))
 503   (let* ((dir (elmo-maildir-folder-directory-internal folder))
 504          (new-len (length (car (elmo-maildir-list-location dir "new"))))
 505          (cur-len (length (car (elmo-maildir-list-location dir "cur")))))
 506     (cons new-len (+ new-len cur-len))))
 507
 508 (luna-define-method elmo-folder-creatable-p ((folder elmo-maildir-folder))
 509   t)
 510
 511 (luna-define-method elmo-folder-writable-p ((folder elmo-maildir-folder))
 512   t)
 513
 514 (luna-define-method elmo-folder-create ((folder elmo-maildir-folder))
 515   (let ((basedir (elmo-maildir-folder-directory-internal folder)))
 516     (condition-case nil
 517         (progn
 518           (dolist (dir '("." "new" "cur" "tmp"))
 519             (setq dir (expand-file-name dir basedir))
 520             (or (file-directory-p dir)
 521                 (progn
 522                   (elmo-make-directory dir)
 523                   (set-file-modes dir 448))))
 524           t)
 525       (error))))
 526
 527 (luna-define-method elmo-folder-delete ((folder elmo-maildir-folder))
 528   (let ((msgs (and (elmo-folder-exists-p folder)
 529                    (elmo-folder-list-messages folder))))
 530     (when (yes-or-no-p (format "%sDelete msgdb and substance of \"%s\"? "
 531                                (if (> (length msgs) 0)
 532                                    (format "%d msg(s) exists. " (length msgs))
 533                                  "")
 534                                (elmo-folder-name-internal folder)))
 535       (let ((basedir (elmo-maildir-folder-directory-internal folder)))
 536         (condition-case nil
 537             (let ((tmp-files (directory-files
 538                               (expand-file-name "tmp" basedir)
 539                               t "[^.].*")))
 540               ;; Delete files in tmp.
 541               (dolist (file tmp-files)
 542                 (delete-file file))
 543               (dolist (dir '("new" "cur" "tmp" "."))
 544                 (setq dir (expand-file-name dir basedir))
 545                 (if (not (file-directory-p dir))
 546                     (error nil)
 547                   (elmo-delete-directory dir t))))
 548           (error nil)))
 549       (elmo-msgdb-delete-path folder)
 550       t)))
 551
 552 (luna-define-method elmo-folder-rename-internal ((folder elmo-maildir-folder)
 553                                                  new-folder)
 554   (let* ((old (elmo-maildir-folder-directory-internal folder))
 555          (new (elmo-maildir-folder-directory-internal new-folder))
 556          (new-dir (directory-file-name (file-name-directory new))))
 557     (unless (file-directory-p old)
 558       (error "No such directory: %s" old))
 559     (when (file-exists-p new)
 560       (error "Already exists directory: %s" new))
 561     (unless (file-directory-p new-dir)
 562       (elmo-make-directory new-dir))
 563     (rename-file old new)
 564     t))
 565
 566 (require 'product)
 567 (product-provide (provide 'elmo-maildir) (require 'elmo-version))
 568
 569 ;;; elmo-maildir.el ends here