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 ;;; ELMO Maildir folder
  44 (eval-and-compile
  45   (luna-define-class elmo-maildir-folder
  46                      (elmo-map-folder)
  47                      (directory unread-locations
  48                                 flagged-locations
  49                                 answered-locations))
  50   (luna-define-internal-accessors 'elmo-maildir-folder))
  51
  52 (luna-define-method elmo-folder-initialize ((folder
  53                                              elmo-maildir-folder)
  54                                             name)
  55   (if (file-name-absolute-p name)
  56       (elmo-maildir-folder-set-directory-internal
  57        folder
  58        (expand-file-name name))
  59     (elmo-maildir-folder-set-directory-internal
  60      folder
  61      (expand-file-name
  62       name
  63       elmo-maildir-folder-path)))
  64   folder)
  65
  66 (luna-define-method elmo-folder-expand-msgdb-path ((folder
  67                                                     elmo-maildir-folder))
  68   (expand-file-name
  69    (elmo-replace-string-as-filename
  70     (elmo-maildir-folder-directory-internal folder))
  71    (expand-file-name
  72     "maildir"
  73     elmo-msgdb-directory)))
  74
  75 (defun elmo-maildir-message-file-name (folder location)
  76   "Get a file name of the message from FOLDER which corresponded to
  77 LOCATION."
  78   (let ((file (file-name-completion
  79                location
  80                (expand-file-name
  81                 "cur"
  82                 (elmo-maildir-folder-directory-internal folder)))))
  83     (if file
  84         (expand-file-name
  85          (if (eq file t) location file)
  86          (expand-file-name
  87           "cur"
  88           (elmo-maildir-folder-directory-internal folder))))))
  89
  90 (defsubst elmo-maildir-list-location (dir &optional child-dir)
  91   (let* ((cur-dir (expand-file-name (or child-dir "cur") dir))
  92          (cur (directory-files cur-dir
  93                                nil "^[^.].*$" t))
  94          unread-locations flagged-locations answered-locations
  95          sym locations flag-list)
  96     (setq locations
  97           (mapcar
  98            (lambda (x)
  99              (if (string-match "^\\([^:]+\\):\\([^:]+\\)$" x)
 100                  (progn
 101                    (setq sym (elmo-match-string 1 x)
 102                          flag-list (string-to-char-list
 103                                     (elmo-match-string 2 x)))
 104                    (when (memq ?F flag-list)
 105                      (setq flagged-locations
 106                            (cons sym flagged-locations)))
 107                    (when (memq ?R flag-list)
 108                      (setq answered-locations
 109                            (cons sym answered-locations)))
 110                    (unless (memq ?S flag-list)
 111                      (setq unread-locations
 112                            (cons sym unread-locations)))
 113                    sym)
 114                x))
 115            cur))
 116     (list locations unread-locations flagged-locations answered-locations)))
 117
 118 (luna-define-method elmo-map-folder-list-message-locations
 119   ((folder elmo-maildir-folder))
 120   (elmo-maildir-update-current folder)
 121   (let ((locs (elmo-maildir-list-location
 122                (elmo-maildir-folder-directory-internal folder))))
 123     ;; 0: locations, 1: unread-locs, 2: flagged-locs 3: answered-locs
 124     (elmo-maildir-folder-set-unread-locations-internal folder (nth 1 locs))
 125     (elmo-maildir-folder-set-flagged-locations-internal folder (nth 2 locs))
 126     (elmo-maildir-folder-set-answered-locations-internal folder (nth 3 locs))
 127     (nth 0 locs)))
 128
 129 (luna-define-method elmo-map-folder-list-unreads
 130   ((folder elmo-maildir-folder))
 131   (elmo-maildir-folder-unread-locations-internal folder))
 132
 133 (luna-define-method elmo-map-folder-list-importants
 134   ((folder elmo-maildir-folder))
 135   (elmo-maildir-folder-flagged-locations-internal folder))
 136
 137 (luna-define-method elmo-map-folder-list-answereds
 138   ((folder elmo-maildir-folder))
 139   (elmo-maildir-folder-answered-locations-internal folder))
 140
 141 (luna-define-method elmo-folder-msgdb-create ((folder elmo-maildir-folder)
 142                                               numbers flag-table)
 143   (let* ((unread-list (elmo-maildir-folder-unread-locations-internal folder))
 144          (flagged-list (elmo-maildir-folder-flagged-locations-internal folder))
 145          (answered-list (elmo-maildir-folder-answered-locations-internal
 146                          folder))
 147          (len (length numbers))
 148          (new-msgdb (elmo-make-msgdb))
 149          (i 0)
 150          entity message-id flags location)
 151     (message "Creating msgdb...")
 152     (dolist (number numbers)
 153       (setq location (elmo-map-message-location folder number))
 154       (setq entity
 155             (elmo-msgdb-create-overview-entity-from-file
 156              number
 157              (elmo-maildir-message-file-name folder location)))
 158       (when entity
 159         (setq message-id (elmo-message-entity-field entity 'message-id)
 160               ;; Precede flag-table to file-info.
 161               flags (copy-sequence
 162                      (elmo-flag-table-get flag-table message-id)))
 163
 164         ;; Already flagged on filename (precede it to flag-table).
 165         (when (member location flagged-list)
 166           (or (memq 'important flags)
 167               (setq flags (cons 'important flags))))
 168         (when (member location answered-list)
 169           (or (memq 'answered flags)
 170               (setq flags (cons 'answered flags))))
 171         (unless (member location unread-list)
 172           (and (memq 'unread flags)
 173                (setq flags (delq 'unread flags))))
 174
 175         ;; Update filename's info portion according to the flag-table.
 176         (when (and (memq 'important flags)
 177                    (not (member location flagged-list)))
 178           (elmo-maildir-set-mark
 179            (elmo-maildir-message-file-name folder location)
 180            ?F)
 181           ;; Append to flagged location list.
 182           (elmo-maildir-folder-set-flagged-locations-internal
 183            folder
 184            (cons location
 185                  (elmo-maildir-folder-flagged-locations-internal
 186                   folder)))
 187           (setq flags (delq 'unread flags)))
 188         (when (and (memq 'answered flags)
 189                    (not (member location answered-list)))
 190           (elmo-maildir-set-mark
 191            (elmo-maildir-message-file-name folder location)
 192            ?R)
 193           ;; Append to answered location list.
 194           (elmo-maildir-folder-set-answered-locations-internal
 195            folder
 196            (cons location
 197                  (elmo-maildir-folder-answered-locations-internal folder)))
 198           (setq flags (delq 'unread flags)))
 199         (when (and (not (memq 'unread flags))
 200                    (member location unread-list))
 201           (elmo-maildir-set-mark
 202            (elmo-maildir-message-file-name folder location)
 203            ?S)
 204           ;; Delete from unread locations.
 205           (elmo-maildir-folder-set-unread-locations-internal
 206            folder
 207            (delete location
 208                    (elmo-maildir-folder-unread-locations-internal
 209                     folder))))
 210         (unless (memq 'unread flags)
 211           (setq flags (delq 'new flags)))
 212         (elmo-global-flags-set flags folder number message-id)
 213         (elmo-msgdb-append-entity new-msgdb entity flags)
 214         (when (> len elmo-display-progress-threshold)
 215           (setq i (1+ i))
 216           (elmo-display-progress
 217            'elmo-maildir-msgdb-create "Creating msgdb..."
 218            (/ (* i 100) len)))))
 219     (message "Creating msgdb...done")
 220     (elmo-msgdb-sort-by-date new-msgdb)))
 221
 222 (defun elmo-maildir-cleanup-temporal (dir)
 223   ;; Delete files in the tmp dir which are not accessed
 224   ;; for more than 36 hours.
 225   (let ((cur-time (current-time))
 226         (count 0)
 227         last-accessed)
 228     (mapcar (function
 229              (lambda (file)
 230                (setq last-accessed (nth 4 (file-attributes file)))
 231                (when (or (> (- (car cur-time)(car last-accessed)) 1)
 232                          (and (eq (- (car cur-time)(car last-accessed)) 1)
 233                               (> (- (cadr cur-time)(cadr last-accessed))
 234                                  64064))) ; 36 hours.
 235                  (message "Maildir: %d tmp file(s) are cleared."
 236                           (setq count (1+ count)))
 237                  (delete-file file))))
 238             (directory-files (expand-file-name "tmp" dir)
 239                              t ; full
 240                              "^[^.].*$" t))))
 241
 242 (defun elmo-maildir-update-current (folder)
 243   "Move all new msgs to cur in the maildir."
 244   (let* ((maildir (elmo-maildir-folder-directory-internal folder))
 245          (news (directory-files (expand-file-name "new"
 246                                                   maildir)
 247                                 nil
 248                                 "^[^.].*$" t)))
 249     ;; cleanup tmp directory.
 250     (elmo-maildir-cleanup-temporal maildir)
 251     ;; move new msgs to cur directory.
 252     (while news
 253       (rename-file
 254        (expand-file-name (car news) (expand-file-name "new" maildir))
 255        (expand-file-name (concat
 256                           (car news)
 257                           (unless (string-match ":2,[A-Z]*$" (car news))
 258                             ":2,"))
 259                          (expand-file-name "cur" maildir)))
 260       (setq news (cdr news)))))
 261
 262 (defun elmo-maildir-set-mark (filename mark)
 263   "Mark the FILENAME file in the maildir.  MARK is a character."
 264   (if (string-match "^\\([^:]+:[12],\\)\\(.*\\)$" filename)
 265       (let ((flaglist (string-to-char-list (elmo-match-string
 266                                             2 filename))))
 267         (unless (memq mark flaglist)
 268           (setq flaglist (sort (cons mark flaglist) '<))
 269           (rename-file filename
 270                        (concat (elmo-match-string 1 filename)
 271                                (char-list-to-string flaglist)))))
 272     ;; Rescue no info file in maildir.
 273     (rename-file filename
 274                  (concat filename ":2," (char-to-string mark))))
 275   t)
 276
 277 (defun elmo-maildir-delete-mark (filename mark)
 278   "Mark the FILENAME file in the maildir.  MARK is a character."
 279   (if (string-match "^\\([^:]+:2,\\)\\(.*\\)$" filename)
 280       (let ((flaglist (string-to-char-list (elmo-match-string
 281                                             2 filename))))
 282         (when (memq mark flaglist)
 283           (setq flaglist (delq mark flaglist))
 284           (rename-file filename
 285                        (concat (elmo-match-string 1 filename)
 286                                (if flaglist
 287                                    (char-list-to-string flaglist))))))))
 288
 289 (defsubst elmo-maildir-set-mark-msgs (folder locs mark)
 290   (dolist (loc locs)
 291     (elmo-maildir-set-mark
 292      (elmo-maildir-message-file-name folder loc)
 293      mark))
 294   t)
 295
 296 (defsubst elmo-maildir-delete-mark-msgs (folder locs mark)
 297   (dolist (loc locs)
 298     (elmo-maildir-delete-mark
 299      (elmo-maildir-message-file-name folder loc)
 300      mark))
 301   t)
 302
 303 (luna-define-method elmo-map-folder-flag-as-important ((folder elmo-maildir-folder)
 304                                                        locs)
 305   (elmo-maildir-set-mark-msgs folder locs ?F))
 306
 307 (luna-define-method elmo-map-folder-unflag-important ((folder elmo-maildir-folder)
 308                                                       locs)
 309   (elmo-maildir-delete-mark-msgs folder locs ?F))
 310
 311 (luna-define-method elmo-map-folder-flag-as-read ((folder elmo-maildir-folder)
 312                                                   locs)
 313   (elmo-maildir-set-mark-msgs folder locs ?S))
 314
 315 (luna-define-method elmo-map-folder-unflag-read ((folder elmo-maildir-folder)
 316                                                  locs)
 317   (elmo-maildir-delete-mark-msgs folder locs ?S))
 318
 319 (luna-define-method elmo-map-folder-flag-as-answered ((folder
 320                                                        elmo-maildir-folder)
 321                                                       locs)
 322   (elmo-maildir-set-mark-msgs folder locs ?R))
 323
 324 (luna-define-method elmo-map-folder-unflag-answered ((folder
 325                                                       elmo-maildir-folder)
 326                                                      locs)
 327   (elmo-maildir-delete-mark-msgs folder locs ?R))
 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 status 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           t)
 415       ;; If an error occured, return nil.
 416       (error))))
 417
 418 (luna-define-method elmo-folder-message-file-p ((folder elmo-maildir-folder))
 419   t)
 420
 421 (luna-define-method elmo-message-file-name ((folder elmo-maildir-folder)
 422                                             number)
 423   (elmo-maildir-message-file-name
 424    folder
 425    (elmo-map-message-location folder number)))
 426
 427 (luna-define-method elmo-folder-message-make-temp-file-p
 428   ((folder elmo-maildir-folder))
 429   t)
 430
 431 (luna-define-method elmo-folder-message-make-temp-files ((folder
 432                                                           elmo-maildir-folder)
 433                                                          numbers
 434                                                          &optional
 435                                                          start-number)
 436   (let ((temp-dir (elmo-folder-make-temporary-directory folder))
 437         (cur-number (if start-number 0)))
 438     (dolist (number numbers)
 439       (elmo-copy-file
 440        (elmo-message-file-name folder number)
 441        (expand-file-name
 442         (int-to-string (if start-number (incf cur-number) number))
 443         temp-dir)))
 444     temp-dir))
 445
 446 (luna-define-method elmo-folder-append-messages :around
 447   ((folder elmo-maildir-folder)
 448    src-folder numbers &optional same-number)
 449   (if (elmo-folder-message-file-p src-folder)
 450       (let ((src-msgdb-exists (not (zerop (elmo-folder-length src-folder))))
 451             (dir (elmo-maildir-folder-directory-internal folder))
 452             (table (elmo-flag-table-load (elmo-folder-msgdb-path folder)))
 453             (succeeds numbers)
 454             filename flags id)
 455         (dolist (number numbers)
 456           (setq flags (elmo-message-flags src-folder (car numbers))
 457                 filename (elmo-maildir-temporal-filename dir))
 458           (elmo-copy-file
 459            (elmo-message-file-name src-folder number)
 460            filename)
 461           (elmo-add-name-to-file
 462            filename
 463            (expand-file-name
 464             (concat "new/" (file-name-nondirectory filename))
 465             dir))
 466           ;; src folder's msgdb is loaded.
 467           (when (setq id (and src-msgdb-exists
 468                               (elmo-message-field src-folder (car numbers)
 469                                                   'message-id)))
 470             (elmo-flag-table-set table id flags))
 471           (elmo-progress-notify 'elmo-folder-move-messages))
 472         (when (elmo-folder-persistent-p folder)
 473           (elmo-flag-table-save (elmo-folder-msgdb-path folder) table))
 474         succeeds)
 475     (luna-call-next-method)))
 476
 477 (luna-define-method elmo-map-folder-delete-messages
 478   ((folder elmo-maildir-folder) locations)
 479   (let (file)
 480     (dolist (location locations)
 481       (setq file (elmo-maildir-message-file-name folder location))
 482       (if (and file
 483                (file-writable-p file)
 484                (not (file-directory-p file)))
 485           (delete-file file)))))
 486
 487 (luna-define-method elmo-map-message-fetch ((folder elmo-maildir-folder)
 488                                             location strategy
 489                                             &optional section unseen)
 490   (let ((file (elmo-maildir-message-file-name folder location)))
 491     (when (file-exists-p file)
 492       (insert-file-contents-as-binary file))))
 493
 494 (luna-define-method elmo-folder-exists-p ((folder elmo-maildir-folder))
 495   (let ((basedir (elmo-maildir-folder-directory-internal folder)))
 496     (and (file-directory-p (expand-file-name "new" basedir))
 497          (file-directory-p (expand-file-name "cur" basedir))
 498          (file-directory-p (expand-file-name "tmp" basedir)))))
 499
 500 (luna-define-method elmo-folder-diff ((folder elmo-maildir-folder))
 501   (let* ((dir (elmo-maildir-folder-directory-internal folder))
 502          (new-len (length (car (elmo-maildir-list-location dir "new"))))
 503          (cur-len (length (car (elmo-maildir-list-location dir "cur")))))
 504     (cons new-len (+ new-len cur-len))))
 505
 506 (luna-define-method elmo-folder-creatable-p ((folder elmo-maildir-folder))
 507   t)
 508
 509 (luna-define-method elmo-folder-writable-p ((folder elmo-maildir-folder))
 510   t)
 511
 512 (luna-define-method elmo-folder-create ((folder elmo-maildir-folder))
 513   (let ((basedir (elmo-maildir-folder-directory-internal folder)))
 514     (condition-case nil
 515         (progn
 516           (dolist (dir '("." "new" "cur" "tmp"))
 517             (setq dir (expand-file-name dir basedir))
 518             (or (file-directory-p dir)
 519                 (progn
 520                   (elmo-make-directory dir)
 521                   (set-file-modes dir 448))))
 522           t)
 523       (error))))
 524
 525 (luna-define-method elmo-folder-delete ((folder elmo-maildir-folder))
 526   (let ((msgs (and (elmo-folder-exists-p folder)
 527                    (elmo-folder-list-messages folder))))
 528     (when (yes-or-no-p (format "%sDelete msgdb and substance of \"%s\"? "
 529                                (if (> (length msgs) 0)
 530                                    (format "%d msg(s) exists. " (length msgs))
 531                                  "")
 532                                (elmo-folder-name-internal folder)))
 533       (let ((basedir (elmo-maildir-folder-directory-internal folder)))
 534         (condition-case nil
 535             (let ((tmp-files (directory-files
 536                               (expand-file-name "tmp" basedir)
 537                               t "[^.].*")))
 538               ;; Delete files in tmp.
 539               (dolist (file tmp-files)
 540                 (delete-file file))
 541               (dolist (dir '("new" "cur" "tmp" "."))
 542                 (setq dir (expand-file-name dir basedir))
 543                 (if (not (file-directory-p dir))
 544                     (error nil)
 545                   (elmo-delete-directory dir t))))
 546           (error nil)))
 547       (elmo-msgdb-delete-path folder)
 548       t)))
 549
 550 (luna-define-method elmo-folder-rename-internal ((folder elmo-maildir-folder)
 551                                                  new-folder)
 552   (let* ((old (elmo-maildir-folder-directory-internal folder))
 553          (new (elmo-maildir-folder-directory-internal new-folder))
 554          (new-dir (directory-file-name (file-name-directory new))))
 555     (unless (file-directory-p old)
 556       (error "No such directory: %s" old))
 557     (when (file-exists-p new)
 558       (error "Already exists directory: %s" new))
 559     (unless (file-directory-p new-dir)
 560       (elmo-make-directory new-dir))
 561     (rename-file old new)
 562     t))
 563
 564 (require 'product)
 565 (product-provide (provide 'elmo-maildir) (require 'elmo-version))
 566
 567 ;;; elmo-maildir.el ends here