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 (assq flag elmo-maildir-flag-specs)))
 318     (elmo-maildir-set-mark-messages folder locations (car spec) (cdr spec))))
 319
 320 (luna-define-method elmo-map-folder-unset-flag ((folder elmo-maildir-folder)
 321                                                 locations flag)
 322   (let ((spec (assq flag elmo-maildir-flag-specs)))
 323     (elmo-maildir-set-mark-messages folder locations
 324                                     (car spec) (not (cdr spec)))))
 325
 326 (luna-define-method elmo-folder-list-subfolders
 327   ((folder elmo-maildir-folder) &optional one-level)
 328   (let ((prefix (concat (elmo-folder-name-internal folder)
 329                         (unless (string= (elmo-folder-prefix-internal folder)
 330                                          (elmo-folder-name-internal folder))
 331                           elmo-path-sep)))
 332         (elmo-list-subdirectories-ignore-regexp
 333          "^\\(\\.\\.?\\|cur\\|tmp\\|new\\)$")
 334         elmo-have-link-count)
 335     (append
 336      (list (elmo-folder-name-internal folder))
 337      (elmo-mapcar-list-of-list
 338       (function (lambda (x) (concat prefix x)))
 339       (elmo-list-subdirectories
 340        (elmo-maildir-folder-directory-internal folder)
 341        ""
 342        one-level)))))
 343
 344 (defvar elmo-maildir-sequence-number-internal 0)
 345
 346 (static-cond
 347  ((>= emacs-major-version 19)
 348   (defun elmo-maildir-make-unique-string ()
 349     "This function generates a string that can be used as a unique
 350 file name for maildir directories."
 351      (let ((cur-time (current-time)))
 352        (format "%.0f.%d_%d.%s"
 353               (+ (* (car cur-time)
 354                     (float 65536)) (cadr cur-time))
 355               (emacs-pid)
 356               (incf elmo-maildir-sequence-number-internal)
 357               (system-name)))))
 358  ((eq emacs-major-version 18)
 359   ;; A fake function for v18
 360   (defun elmo-maildir-make-unique-string ()
 361     "This function generates a string that can be used as a unique
 362 file name for maildir directories."
 363     (unless (fboundp 'float-to-string)
 364       (load-library "float"))
 365     (let ((time (current-time)))
 366       (format "%s%d.%d.%s"
 367               (substring
 368                (float-to-string
 369                 (f+ (f* (f (car time))
 370                         (f 65536))
 371                     (f (cadr time))))
 372                0 5)
 373               (cadr time)
 374               (% (abs (random t)) 10000); dummy pid
 375               (system-name))))))
 376
 377 (defun elmo-maildir-temporal-filename (basedir)
 378   (let ((filename (expand-file-name
 379                    (concat "tmp/" (elmo-maildir-make-unique-string))
 380                    basedir)))
 381     (unless (file-exists-p (file-name-directory filename))
 382       (make-directory (file-name-directory filename)))
 383     (while (file-exists-p filename)
 384 ;;; I don't want to wait.
 385 ;;;   (sleep-for 2)
 386       (setq filename
 387             (expand-file-name
 388              (concat "tmp/" (elmo-maildir-make-unique-string))
 389              basedir)))
 390     filename))
 391
 392 (luna-define-method elmo-folder-append-buffer ((folder elmo-maildir-folder)
 393                                                &optional status number)
 394   (let ((basedir (elmo-maildir-folder-directory-internal folder))
 395         (src-buf (current-buffer))
 396         dst-buf filename)
 397     (condition-case nil
 398         (with-temp-buffer
 399           (setq filename (elmo-maildir-temporal-filename basedir))
 400           (setq dst-buf (current-buffer))
 401           (with-current-buffer src-buf
 402             (copy-to-buffer dst-buf (point-min) (point-max)))
 403           (as-binary-output-file
 404            (write-region (point-min) (point-max) filename nil 'no-msg))
 405           ;; add link from new.
 406           (elmo-add-name-to-file
 407            filename
 408            (expand-file-name
 409             (concat "new/" (file-name-nondirectory filename))
 410             basedir))
 411           t)
 412       ;; If an error occured, return nil.
 413       (error))))
 414
 415 (luna-define-method elmo-folder-message-file-p ((folder elmo-maildir-folder))
 416   t)
 417
 418 (luna-define-method elmo-message-file-name ((folder elmo-maildir-folder)
 419                                             number)
 420   (elmo-maildir-message-file-name
 421    folder
 422    (elmo-map-message-location folder number)))
 423
 424 (luna-define-method elmo-folder-message-make-temp-file-p
 425   ((folder elmo-maildir-folder))
 426   t)
 427
 428 (luna-define-method elmo-folder-message-make-temp-files ((folder
 429                                                           elmo-maildir-folder)
 430                                                          numbers
 431                                                          &optional
 432                                                          start-number)
 433   (let ((temp-dir (elmo-folder-make-temporary-directory folder))
 434         (cur-number (if start-number 0)))
 435     (dolist (number numbers)
 436       (elmo-copy-file
 437        (elmo-message-file-name folder number)
 438        (expand-file-name
 439         (int-to-string (if start-number (incf cur-number) number))
 440         temp-dir)))
 441     temp-dir))
 442
 443 (luna-define-method elmo-folder-append-messages :around
 444   ((folder elmo-maildir-folder)
 445    src-folder numbers &optional same-number)
 446   (if (elmo-folder-message-file-p src-folder)
 447       (let ((src-msgdb-exists (not (zerop (elmo-folder-length src-folder))))
 448             (dir (elmo-maildir-folder-directory-internal folder))
 449             (table (elmo-flag-table-load (elmo-folder-msgdb-path folder)))
 450             (succeeds numbers)
 451             filename flags id)
 452         (dolist (number numbers)
 453           (setq flags (elmo-message-flags src-folder (car numbers))
 454                 filename (elmo-maildir-temporal-filename dir))
 455           (elmo-copy-file
 456            (elmo-message-file-name src-folder number)
 457            filename)
 458           (elmo-add-name-to-file
 459            filename
 460            (expand-file-name
 461             (concat "new/" (file-name-nondirectory filename))
 462             dir))
 463           ;; src folder's msgdb is loaded.
 464           (when (setq id (and src-msgdb-exists
 465                               (elmo-message-field src-folder (car numbers)
 466                                                   'message-id)))
 467             (elmo-flag-table-set table id flags))
 468           (elmo-progress-notify 'elmo-folder-move-messages))
 469         (when (elmo-folder-persistent-p folder)
 470           (elmo-flag-table-save (elmo-folder-msgdb-path folder) table))
 471         succeeds)
 472     (luna-call-next-method)))
 473
 474 (luna-define-method elmo-map-folder-delete-messages
 475   ((folder elmo-maildir-folder) locations)
 476   (let (file)
 477     (dolist (location locations)
 478       (setq file (elmo-maildir-message-file-name folder location))
 479       (if (and file
 480                (file-writable-p file)
 481                (not (file-directory-p file)))
 482           (delete-file file)))))
 483
 484 (luna-define-method elmo-map-message-fetch ((folder elmo-maildir-folder)
 485                                             location strategy
 486                                             &optional section unseen)
 487   (let ((file (elmo-maildir-message-file-name folder location)))
 488     (when (file-exists-p file)
 489       (insert-file-contents-as-binary file))))
 490
 491 (luna-define-method elmo-folder-exists-p ((folder elmo-maildir-folder))
 492   (let ((basedir (elmo-maildir-folder-directory-internal folder)))
 493     (and (file-directory-p (expand-file-name "new" basedir))
 494          (file-directory-p (expand-file-name "cur" basedir))
 495          (file-directory-p (expand-file-name "tmp" basedir)))))
 496
 497 (luna-define-method elmo-folder-diff ((folder elmo-maildir-folder))
 498   (let* ((dir (elmo-maildir-folder-directory-internal folder))
 499          (new-len (length (car (elmo-maildir-list-location dir "new"))))
 500          (cur-len (length (car (elmo-maildir-list-location dir "cur")))))
 501     (cons new-len (+ new-len cur-len))))
 502
 503 (luna-define-method elmo-folder-creatable-p ((folder elmo-maildir-folder))
 504   t)
 505
 506 (luna-define-method elmo-folder-writable-p ((folder elmo-maildir-folder))
 507   t)
 508
 509 (luna-define-method elmo-folder-create ((folder elmo-maildir-folder))
 510   (let ((basedir (elmo-maildir-folder-directory-internal folder)))
 511     (condition-case nil
 512         (progn
 513           (dolist (dir '("." "new" "cur" "tmp"))
 514             (setq dir (expand-file-name dir basedir))
 515             (or (file-directory-p dir)
 516                 (progn
 517                   (elmo-make-directory dir)
 518                   (set-file-modes dir 448))))
 519           t)
 520       (error))))
 521
 522 (luna-define-method elmo-folder-delete ((folder elmo-maildir-folder))
 523   (let ((msgs (and (elmo-folder-exists-p folder)
 524                    (elmo-folder-list-messages folder))))
 525     (when (yes-or-no-p (format "%sDelete msgdb and substance of \"%s\"? "
 526                                (if (> (length msgs) 0)
 527                                    (format "%d msg(s) exists. " (length msgs))
 528                                  "")
 529                                (elmo-folder-name-internal folder)))
 530       (let ((basedir (elmo-maildir-folder-directory-internal folder)))
 531         (condition-case nil
 532             (let ((tmp-files (directory-files
 533                               (expand-file-name "tmp" basedir)
 534                               t "[^.].*")))
 535               ;; Delete files in tmp.
 536               (dolist (file tmp-files)
 537                 (delete-file file))
 538               (dolist (dir '("new" "cur" "tmp" "."))
 539                 (setq dir (expand-file-name dir basedir))
 540                 (if (not (file-directory-p dir))
 541                     (error nil)
 542                   (elmo-delete-directory dir t))))
 543           (error nil)))
 544       (elmo-msgdb-delete-path folder)
 545       t)))
 546
 547 (luna-define-method elmo-folder-rename-internal ((folder elmo-maildir-folder)
 548                                                  new-folder)
 549   (let* ((old (elmo-maildir-folder-directory-internal folder))
 550          (new (elmo-maildir-folder-directory-internal new-folder))
 551          (new-dir (directory-file-name (file-name-directory new))))
 552     (unless (file-directory-p old)
 553       (error "No such directory: %s" old))
 554     (when (file-exists-p new)
 555       (error "Already exists directory: %s" new))
 556     (unless (file-directory-p new-dir)
 557       (elmo-make-directory new-dir))
 558     (rename-file old new)
 559     t))
 560
 561 (require 'product)
 562 (product-provide (provide 'elmo-maildir) (require 'elmo-version))
 563
 564 ;;; elmo-maildir.el ends here