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 flagged-locations))
  48   (luna-define-internal-accessors 'elmo-maildir-folder))
  49
  50 (luna-define-method elmo-folder-initialize ((folder
  51                                              elmo-maildir-folder)
  52                                             name)
  53   (if (file-name-absolute-p name)
  54       (elmo-maildir-folder-set-directory-internal
  55        folder
  56        (expand-file-name name))
  57     (elmo-maildir-folder-set-directory-internal
  58      folder
  59      (expand-file-name
  60       name
  61       elmo-maildir-folder-path)))
  62   folder)
  63
  64 (luna-define-method elmo-folder-expand-msgdb-path ((folder
  65                                                     elmo-maildir-folder))
  66   (expand-file-name
  67    (elmo-replace-string-as-filename
  68     (elmo-maildir-folder-directory-internal folder))
  69    (expand-file-name
  70     "maildir"
  71     elmo-msgdb-directory)))
  72
  73 (defun elmo-maildir-message-file-name (folder location)
  74   "Get a file name of the message from FOLDER which corresponded to
  75 LOCATION."
  76   (let ((file (file-name-completion
  77                location
  78                (expand-file-name
  79                 "cur"
  80                 (elmo-maildir-folder-directory-internal folder)))))
  81     (if file
  82         (expand-file-name
  83          (if (eq file t) location file)
  84          (expand-file-name
  85           "cur"
  86           (elmo-maildir-folder-directory-internal folder))))))
  87
  88 (defsubst elmo-maildir-list-location (dir &optional child-dir)
  89   (let* ((cur-dir (expand-file-name (or child-dir "cur") dir))
  90          (cur (directory-files cur-dir
  91                                nil "^[^.].*$" t))
  92          unread-locations flagged-locations seen flagged sym
  93          locations)
  94     (setq locations
  95           (mapcar
  96            (lambda (x)
  97              (if (string-match "^\\([^:]+\\):\\([^:]+\\)$" x)
  98                  (progn
  99                    (setq seen nil)
 100                    (save-match-data
 101                      (cond
 102                       ((string-match "S" (elmo-match-string 2 x))
 103                        (setq seen t))
 104                       ((string-match "F" (elmo-match-string 2 x))
 105                        (setq flagged t))))
 106                    (setq sym (elmo-match-string 1 x))
 107                    (unless seen (setq unread-locations
 108                                       (cons sym unread-locations)))
 109                    (if flagged (setq flagged-locations
 110                                      (cons sym flagged-locations)))
 111                    sym)
 112                x))
 113            cur))
 114     (list locations unread-locations flagged-locations)))
 115
 116 (luna-define-method elmo-map-folder-list-message-locations
 117   ((folder elmo-maildir-folder))
 118   (elmo-maildir-update-current folder)
 119   (let ((locs (elmo-maildir-list-location
 120                (elmo-maildir-folder-directory-internal folder))))
 121     ;; 0: locations, 1: unread-locations, 2: flagged-locations
 122     (elmo-maildir-folder-set-unread-locations-internal folder (nth 1 locs))
 123     (elmo-maildir-folder-set-flagged-locations-internal folder (nth 2 locs))
 124     (nth 0 locs)))
 125
 126 (luna-define-method elmo-map-folder-list-unreads
 127   ((folder elmo-maildir-folder))
 128   (elmo-maildir-folder-unread-locations-internal folder))
 129
 130 (luna-define-method elmo-map-folder-list-importants
 131   ((folder elmo-maildir-folder))
 132   (elmo-maildir-folder-flagged-locations-internal folder))
 133
 134 (luna-define-method elmo-folder-msgdb-create
 135   ((folder elmo-maildir-folder)
 136    numbers new-mark already-mark seen-mark important-mark seen-list)
 137   (let* ((unread-list (elmo-maildir-folder-unread-locations-internal folder))
 138          (flagged-list (elmo-maildir-folder-flagged-locations-internal folder))
 139          (len (length numbers))
 140          (i 0)
 141          overview number-alist mark-alist entity
 142          location pair mark)
 143     (message "Creating msgdb...")
 144     (dolist
 145         (number numbers)
 146       (setq location (elmo-map-message-location folder number))
 147       (setq entity
 148             (elmo-msgdb-create-overview-entity-from-file
 149              number
 150              (elmo-maildir-message-file-name folder location)))
 151       (when entity
 152         (setq overview
 153               (elmo-msgdb-append-element overview entity))
 154         (setq number-alist
 155               (elmo-msgdb-number-add number-alist
 156                                      (elmo-msgdb-overview-entity-get-number
 157                                       entity)
 158                                      (elmo-msgdb-overview-entity-get-id
 159                                       entity)))
 160         (cond
 161          ((member location unread-list)
 162           (setq mark new-mark)) ; unread!
 163          ((member location flagged-list)
 164           (setq mark important-mark)))
 165         (if (setq mark (or (elmo-msgdb-global-mark-get
 166                             (elmo-msgdb-overview-entity-get-id
 167                              entity))
 168                            mark))
 169             (setq mark-alist
 170                   (elmo-msgdb-mark-append
 171                    mark-alist
 172                    (elmo-msgdb-overview-entity-get-number
 173                     entity)
 174                    mark)))
 175         (when (> len elmo-display-progress-threshold)
 176           (setq i (1+ i))
 177           (elmo-display-progress
 178            'elmo-maildir-msgdb-create "Creating msgdb..."
 179            (/ (* i 100) len)))))
 180     (message "Creating msgdb...done")
 181     (elmo-msgdb-sort-by-date
 182      (list overview number-alist mark-alist))))
 183
 184 (defun elmo-maildir-cleanup-temporal (dir)
 185   ;; Delete files in the tmp dir which are not accessed
 186   ;; for more than 36 hours.
 187   (let ((cur-time (current-time))
 188         (count 0)
 189         last-accessed)
 190     (mapcar (function
 191              (lambda (file)
 192                (setq last-accessed (nth 4 (file-attributes file)))
 193                (when (or (> (- (car cur-time)(car last-accessed)) 1)
 194                          (and (eq (- (car cur-time)(car last-accessed)) 1)
 195                               (> (- (cadr cur-time)(cadr last-accessed))
 196                                  64064))) ; 36 hours.
 197                  (message "Maildir: %d tmp file(s) are cleared."
 198                           (setq count (1+ count)))
 199                  (delete-file file))))
 200             (directory-files (expand-file-name "tmp" dir)
 201                              t ; full
 202                              "^[^.].*$" t))))
 203
 204 (defun elmo-maildir-update-current (folder)
 205   "Move all new msgs to cur in the maildir."
 206   (let* ((maildir (elmo-maildir-folder-directory-internal folder))
 207          (news (directory-files (expand-file-name "new"
 208                                                   maildir)
 209                                 nil
 210                                 "^[^.].*$" t)))
 211     ;; cleanup tmp directory.
 212     (elmo-maildir-cleanup-temporal maildir)
 213     ;; move new msgs to cur directory.
 214     (while news
 215       (rename-file
 216        (expand-file-name (car news) (expand-file-name "new" maildir))
 217        (expand-file-name (concat
 218                           (car news)
 219                           (unless (string-match ":2,[A-Z]*$" (car news))
 220                             ":2,"))
 221                          (expand-file-name "cur" maildir)))
 222       (setq news (cdr news)))))
 223
 224 (defun elmo-maildir-set-mark (filename mark)
 225   "Mark the FILENAME file in the maildir.  MARK is a character."
 226   (if (string-match "^\\([^:]+:[12],\\)\\(.*\\)$" filename)
 227       (let ((flaglist (string-to-char-list (elmo-match-string
 228                                             2 filename))))
 229         (unless (memq mark flaglist)
 230           (setq flaglist (sort (cons mark flaglist) '<))
 231           (rename-file filename
 232                        (concat (elmo-match-string 1 filename)
 233                                (char-list-to-string flaglist)))))
 234     ;; Rescue no info file in maildir.
 235     (rename-file filename
 236                  (concat filename ":2," (char-to-string mark))))
 237   t)
 238
 239 (defun elmo-maildir-delete-mark (filename mark)
 240   "Mark the FILENAME file in the maildir.  MARK is a character."
 241   (if (string-match "^\\([^:]+:2,\\)\\(.*\\)$" filename)
 242       (let ((flaglist (string-to-char-list (elmo-match-string
 243                                             2 filename))))
 244         (when (memq mark flaglist)
 245           (setq flaglist (delq mark flaglist))
 246           (rename-file filename
 247                        (concat (elmo-match-string 1 filename)
 248                                (if flaglist
 249                                    (char-list-to-string flaglist))))))))
 250
 251 (defsubst elmo-maildir-set-mark-msgs (folder locs mark)
 252   (dolist (loc locs)
 253     (elmo-maildir-set-mark
 254      (elmo-maildir-message-file-name folder loc)
 255      mark))
 256   t)
 257
 258 (defsubst elmo-maildir-delete-mark-msgs (folder locs mark)
 259   (dolist (loc locs)
 260     (elmo-maildir-delete-mark
 261      (elmo-maildir-message-file-name folder loc)
 262      mark))
 263   t)
 264
 265 (luna-define-method elmo-map-folder-mark-as-important ((folder elmo-maildir-folder)
 266                                                        locs)
 267   (elmo-maildir-set-mark-msgs folder locs ?F))
 268
 269 (luna-define-method elmo-map-folder-unmark-important ((folder elmo-maildir-folder)
 270                                                       locs)
 271   (elmo-maildir-delete-mark-msgs folder locs ?F))
 272
 273 (luna-define-method elmo-map-folder-mark-as-read ((folder elmo-maildir-folder)
 274                                                   locs)
 275   (elmo-maildir-set-mark-msgs folder locs ?S))
 276
 277 (luna-define-method elmo-map-folder-unmark-read ((folder elmo-maildir-folder)
 278                                                  locs)
 279   (elmo-maildir-delete-mark-msgs folder locs ?S))
 280
 281 (luna-define-method elmo-folder-list-subfolders
 282   ((folder elmo-maildir-folder) &optional one-level)
 283   (let ((prefix (concat (elmo-folder-name-internal folder)
 284                         (unless (string= (elmo-folder-prefix-internal folder)
 285                                          (elmo-folder-name-internal folder))
 286                           elmo-path-sep)))
 287         (elmo-list-subdirectories-ignore-regexp
 288          "^\\(\\.\\.?\\|cur\\|tmp\\|new\\)$")
 289         elmo-have-link-count)
 290     (append
 291      (list (elmo-folder-name-internal folder))
 292      (elmo-mapcar-list-of-list
 293       (function (lambda (x) (concat prefix x)))
 294       (elmo-list-subdirectories
 295        (elmo-maildir-folder-directory-internal folder)
 296        ""
 297        one-level)))))
 298
 299 (defvar elmo-maildir-sequence-number-internal 0)
 300
 301 (static-cond
 302  ((>= emacs-major-version 19)
 303   (defun elmo-maildir-make-unique-string ()
 304     "This function generates a string that can be used as a unique
 305 file name for maildir directories."
 306      (let ((cur-time (current-time)))
 307        (format "%.0f.%d_%d.%s"
 308               (+ (* (car cur-time)
 309                     (float 65536)) (cadr cur-time))
 310               (emacs-pid)
 311               (incf elmo-maildir-sequence-number-internal)
 312               (system-name)))))
 313  ((eq emacs-major-version 18)
 314   ;; A fake function for v18
 315   (defun elmo-maildir-make-unique-string ()
 316     "This function generates a string that can be used as a unique
 317 file name for maildir directories."
 318     (unless (fboundp 'float-to-string)
 319       (load-library "float"))
 320     (let ((time (current-time)))
 321       (format "%s%d.%d.%s"
 322               (substring
 323                (float-to-string
 324                 (f+ (f* (f (car time))
 325                         (f 65536))
 326                     (f (cadr time))))
 327                0 5)
 328               (cadr time)
 329               (% (abs (random t)) 10000); dummy pid
 330               (system-name))))))
 331
 332 (defun elmo-maildir-temporal-filename (basedir)
 333   (let ((filename (expand-file-name
 334                    (concat "tmp/" (elmo-maildir-make-unique-string))
 335                    basedir)))
 336     (unless (file-exists-p (file-name-directory filename))
 337       (make-directory (file-name-directory filename)))
 338     (while (file-exists-p filename)
 339 ;;; I don't want to wait.
 340 ;;;   (sleep-for 2)
 341       (setq filename
 342             (expand-file-name
 343              (concat "tmp/" (elmo-maildir-make-unique-string))
 344              basedir)))
 345     filename))
 346
 347 (luna-define-method elmo-folder-append-buffer ((folder elmo-maildir-folder)
 348                                                unread &optional number)
 349   (let ((basedir (elmo-maildir-folder-directory-internal folder))
 350         (src-buf (current-buffer))
 351         dst-buf filename)
 352     (condition-case nil
 353         (with-temp-buffer
 354           (setq filename (elmo-maildir-temporal-filename basedir))
 355           (setq dst-buf (current-buffer))
 356           (with-current-buffer src-buf
 357             (copy-to-buffer dst-buf (point-min) (point-max)))
 358           (as-binary-output-file
 359            (write-region (point-min) (point-max) filename nil 'no-msg))
 360           ;; add link from new.
 361           (elmo-add-name-to-file
 362            filename
 363            (expand-file-name
 364             (concat "new/" (file-name-nondirectory filename))
 365             basedir))
 366           t)
 367       ;; If an error occured, return nil.
 368       (error))))
 369
 370 (luna-define-method elmo-folder-message-file-p ((folder elmo-maildir-folder))
 371   t)
 372
 373 (luna-define-method elmo-message-file-name ((folder elmo-maildir-folder)
 374                                             number)
 375   (elmo-maildir-message-file-name
 376    folder
 377    (elmo-map-message-location folder number)))
 378
 379 (luna-define-method elmo-folder-message-make-temp-file-p
 380   ((folder elmo-maildir-folder))
 381   t)
 382
 383 (luna-define-method elmo-folder-message-make-temp-files ((folder
 384                                                           elmo-maildir-folder)
 385                                                          numbers
 386                                                          &optional
 387                                                          start-number)
 388   (let ((temp-dir (elmo-folder-make-temporary-directory folder))
 389         (cur-number (if start-number 0)))
 390     (dolist (number numbers)
 391       (elmo-copy-file
 392        (elmo-message-file-name folder number)
 393        (expand-file-name
 394         (int-to-string (if start-number (incf cur-number) number))
 395         temp-dir)))
 396     temp-dir))
 397
 398 (luna-define-method elmo-folder-append-messages :around
 399   ((folder elmo-maildir-folder)
 400    src-folder numbers unread-marks &optional same-number)
 401   (if (elmo-folder-message-file-p src-folder)
 402       (let ((dir (elmo-maildir-folder-directory-internal folder))
 403             (succeeds numbers)
 404             filename)
 405         (dolist (number numbers)
 406           (setq filename (elmo-maildir-temporal-filename dir))
 407           (elmo-copy-file
 408            (elmo-message-file-name src-folder number)
 409            filename)
 410           (elmo-add-name-to-file
 411            filename
 412            (expand-file-name
 413             (concat "new/" (file-name-nondirectory filename))
 414             dir))
 415           (elmo-progress-notify 'elmo-folder-move-messages))
 416         succeeds)
 417     (luna-call-next-method)))
 418
 419 (luna-define-method elmo-map-folder-delete-messages
 420   ((folder elmo-maildir-folder) locations)
 421   (let (file)
 422     (dolist (location locations)
 423       (setq file (elmo-maildir-message-file-name folder location))
 424       (if (and file
 425                (file-writable-p file)
 426                (not (file-directory-p file)))
 427           (delete-file file)))))
 428
 429 (luna-define-method elmo-map-message-fetch ((folder elmo-maildir-folder)
 430                                             location strategy
 431                                             &optional section unseen)
 432   (let ((file (elmo-maildir-message-file-name folder location)))
 433     (when (file-exists-p file)
 434       (insert-file-contents-as-binary file))))
 435
 436 (luna-define-method elmo-folder-exists-p ((folder elmo-maildir-folder))
 437   (let ((basedir (elmo-maildir-folder-directory-internal folder)))
 438     (and (file-directory-p (expand-file-name "new" basedir))
 439          (file-directory-p (expand-file-name "cur" basedir))
 440          (file-directory-p (expand-file-name "tmp" basedir)))))
 441
 442 (luna-define-method elmo-folder-diff ((folder elmo-maildir-folder)
 443                                       &optional numbers)
 444   (let* ((dir (elmo-maildir-folder-directory-internal folder))
 445          (new-len (length (car (elmo-maildir-list-location dir "new"))))
 446          (cur-len (length (car (elmo-maildir-list-location dir "cur")))))
 447     (cons new-len (+ new-len cur-len))))
 448
 449 (luna-define-method elmo-folder-creatable-p ((folder elmo-maildir-folder))
 450   t)
 451
 452 (luna-define-method elmo-folder-writable-p ((folder elmo-maildir-folder))
 453   t)
 454
 455 (luna-define-method elmo-folder-create ((folder elmo-maildir-folder))
 456   (let ((basedir (elmo-maildir-folder-directory-internal folder)))
 457     (condition-case nil
 458         (progn
 459           (dolist (dir '("." "new" "cur" "tmp"))
 460             (setq dir (expand-file-name dir basedir))
 461             (or (file-directory-p dir)
 462                 (progn
 463                   (elmo-make-directory dir)
 464                   (set-file-modes dir 448))))
 465           t)
 466       (error))))
 467
 468 (luna-define-method elmo-folder-delete :before ((folder elmo-maildir-folder))
 469   (let ((basedir (elmo-maildir-folder-directory-internal folder)))
 470     (condition-case nil
 471         (let ((tmp-files (directory-files
 472                           (expand-file-name "tmp" basedir)
 473                           t "[^.].*")))
 474           ;; Delete files in tmp.
 475           (dolist (file tmp-files)
 476             (delete-file file))
 477           (dolist (dir '("new" "cur" "tmp" "."))
 478             (setq dir (expand-file-name dir basedir))
 479             (if (not (file-directory-p dir))
 480                 (error nil)
 481               (elmo-delete-directory dir t)))
 482           t)
 483       (error nil))))
 484
 485 (luna-define-method elmo-folder-rename-internal ((folder elmo-maildir-folder)
 486                                                  new-folder)
 487   (let* ((old (elmo-maildir-folder-directory-internal folder))
 488          (new (elmo-maildir-folder-directory-internal new-folder))
 489          (new-dir (directory-file-name (file-name-directory new))))
 490     (unless (file-directory-p old)
 491       (error "No such directory: %s" old))
 492     (when (file-exists-p new)
 493       (error "Already exists directory: %s" new))
 494     (unless (file-directory-p new-dir)
 495       (elmo-make-directory new-dir))
 496     (rename-file old new)
 497     t))
 498
 499 (require 'product)
 500 (product-provide (provide 'elmo-maildir) (require 'elmo-version))
 501
 502 ;;; elmo-maildir.el ends here