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-message-entity-from-file
 156              (elmo-msgdb-message-entity-handler new-msgdb)
 157              number
 158              (elmo-maildir-message-file-name folder location)))
 159       (when entity
 160         (setq message-id (elmo-message-entity-field entity 'message-id)
 161               ;; Precede flag-table to file-info.
 162               flags (copy-sequence
 163                      (elmo-flag-table-get flag-table message-id)))
 164
 165         ;; Already flagged on filename (precede it to flag-table).
 166         (when (member location flagged-list)
 167           (or (memq 'important flags)
 168               (setq flags (cons 'important flags))))
 169         (when (member location answered-list)
 170           (or (memq 'answered flags)
 171               (setq flags (cons 'answered flags))))
 172         (unless (member location unread-list)
 173           (and (memq 'unread flags)
 174                (setq flags (delq 'unread flags))))
 175
 176         ;; Update filename's info portion according to the flag-table.
 177         (when (and (memq 'important flags)
 178                    (not (member location flagged-list)))
 179           (elmo-maildir-set-mark
 180            (elmo-maildir-message-file-name folder location)
 181            ?F)
 182           ;; Append to flagged location list.
 183           (elmo-maildir-folder-set-flagged-locations-internal
 184            folder
 185            (cons location
 186                  (elmo-maildir-folder-flagged-locations-internal
 187                   folder)))
 188           (setq flags (delq 'unread flags)))
 189         (when (and (memq 'answered flags)
 190                    (not (member location answered-list)))
 191           (elmo-maildir-set-mark
 192            (elmo-maildir-message-file-name folder location)
 193            ?R)
 194           ;; Append to answered location list.
 195           (elmo-maildir-folder-set-answered-locations-internal
 196            folder
 197            (cons location
 198                  (elmo-maildir-folder-answered-locations-internal folder)))
 199           (setq flags (delq 'unread flags)))
 200         (when (and (not (memq 'unread flags))
 201                    (member location unread-list))
 202           (elmo-maildir-set-mark
 203            (elmo-maildir-message-file-name folder location)
 204            ?S)
 205           ;; Delete from unread locations.
 206           (elmo-maildir-folder-set-unread-locations-internal
 207            folder
 208            (delete location
 209                    (elmo-maildir-folder-unread-locations-internal
 210                     folder))))
 211         (unless (memq 'unread flags)
 212           (setq flags (delq 'new flags)))
 213         (elmo-global-flags-set flags folder number message-id)
 214         (elmo-msgdb-append-entity new-msgdb entity flags)
 215         (when (> len elmo-display-progress-threshold)
 216           (setq i (1+ i))
 217           (elmo-display-progress
 218            'elmo-maildir-msgdb-create "Creating msgdb..."
 219            (/ (* i 100) len)))))
 220     (message "Creating msgdb...done")
 221     (elmo-msgdb-sort-by-date new-msgdb)))
 222
 223 (defun elmo-maildir-cleanup-temporal (dir)
 224   ;; Delete files in the tmp dir which are not accessed
 225   ;; for more than 36 hours.
 226   (let ((cur-time (current-time))
 227         (count 0)
 228         last-accessed)
 229     (mapcar (function
 230              (lambda (file)
 231                (setq last-accessed (nth 4 (file-attributes file)))
 232                (when (or (> (- (car cur-time)(car last-accessed)) 1)
 233                          (and (eq (- (car cur-time)(car last-accessed)) 1)
 234                               (> (- (cadr cur-time)(cadr last-accessed))
 235                                  64064))) ; 36 hours.
 236                  (message "Maildir: %d tmp file(s) are cleared."
 237                           (setq count (1+ count)))
 238                  (delete-file file))))
 239             (directory-files (expand-file-name "tmp" dir)
 240                              t ; full
 241                              "^[^.].*$" t))))
 242
 243 (defun elmo-maildir-update-current (folder)
 244   "Move all new msgs to cur in the maildir."
 245   (let* ((maildir (elmo-maildir-folder-directory-internal folder))
 246          (news (directory-files (expand-file-name "new"
 247                                                   maildir)
 248                                 nil
 249                                 "^[^.].*$" t)))
 250     ;; cleanup tmp directory.
 251     (elmo-maildir-cleanup-temporal maildir)
 252     ;; move new msgs to cur directory.
 253     (while news
 254       (rename-file
 255        (expand-file-name (car news) (expand-file-name "new" maildir))
 256        (expand-file-name (concat
 257                           (car news)
 258                           (unless (string-match ":2,[A-Z]*$" (car news))
 259                             ":2,"))
 260                          (expand-file-name "cur" maildir)))
 261       (setq news (cdr news)))))
 262
 263 (defun elmo-maildir-set-mark (filename mark)
 264   "Mark the FILENAME file in the maildir.  MARK is a character."
 265   (if (string-match "^\\([^:]+:[12],\\)\\(.*\\)$" filename)
 266       (let ((flaglist (string-to-char-list (elmo-match-string
 267                                             2 filename))))
 268         (unless (memq mark flaglist)
 269           (setq flaglist (sort (cons mark flaglist) '<))
 270           (rename-file filename
 271                        (concat (elmo-match-string 1 filename)
 272                                (char-list-to-string flaglist)))))
 273     ;; Rescue no info file in maildir.
 274     (rename-file filename
 275                  (concat filename ":2," (char-to-string mark))))
 276   t)
 277
 278 (defun elmo-maildir-delete-mark (filename mark)
 279   "Mark the FILENAME file in the maildir.  MARK is a character."
 280   (if (string-match "^\\([^:]+:2,\\)\\(.*\\)$" filename)
 281       (let ((flaglist (string-to-char-list (elmo-match-string
 282                                             2 filename))))
 283         (when (memq mark flaglist)
 284           (setq flaglist (delq mark flaglist))
 285           (rename-file filename
 286                        (concat (elmo-match-string 1 filename)
 287                                (if flaglist
 288                                    (char-list-to-string flaglist))))))))
 289
 290 (defsubst elmo-maildir-set-mark-msgs (folder locs mark)
 291   (dolist (loc locs)
 292     (elmo-maildir-set-mark
 293      (elmo-maildir-message-file-name folder loc)
 294      mark))
 295   t)
 296
 297 (defsubst elmo-maildir-delete-mark-msgs (folder locs mark)
 298   (dolist (loc locs)
 299     (elmo-maildir-delete-mark
 300      (elmo-maildir-message-file-name folder loc)
 301      mark))
 302   t)
 303
 304 (luna-define-method elmo-map-folder-flag-as-important ((folder elmo-maildir-folder)
 305                                                        locs)
 306   (elmo-maildir-set-mark-msgs folder locs ?F))
 307
 308 (luna-define-method elmo-map-folder-unflag-important ((folder elmo-maildir-folder)
 309                                                       locs)
 310   (elmo-maildir-delete-mark-msgs folder locs ?F))
 311
 312 (luna-define-method elmo-map-folder-flag-as-read ((folder elmo-maildir-folder)
 313                                                   locs)
 314   (elmo-maildir-set-mark-msgs folder locs ?S))
 315
 316 (luna-define-method elmo-map-folder-unflag-read ((folder elmo-maildir-folder)
 317                                                  locs)
 318   (elmo-maildir-delete-mark-msgs folder locs ?S))
 319
 320 (luna-define-method elmo-map-folder-flag-as-answered ((folder
 321                                                        elmo-maildir-folder)
 322                                                       locs)
 323   (elmo-maildir-set-mark-msgs folder locs ?R))
 324
 325 (luna-define-method elmo-map-folder-unflag-answered ((folder
 326                                                       elmo-maildir-folder)
 327                                                      locs)
 328   (elmo-maildir-delete-mark-msgs folder locs ?R))
 329
 330 (luna-define-method elmo-folder-list-subfolders
 331   ((folder elmo-maildir-folder) &optional one-level)
 332   (let ((prefix (concat (elmo-folder-name-internal folder)
 333                         (unless (string= (elmo-folder-prefix-internal folder)
 334                                          (elmo-folder-name-internal folder))
 335                           elmo-path-sep)))
 336         (elmo-list-subdirectories-ignore-regexp
 337          "^\\(\\.\\.?\\|cur\\|tmp\\|new\\)$")
 338         elmo-have-link-count)
 339     (append
 340      (list (elmo-folder-name-internal folder))
 341      (elmo-mapcar-list-of-list
 342       (function (lambda (x) (concat prefix x)))
 343       (elmo-list-subdirectories
 344        (elmo-maildir-folder-directory-internal folder)
 345        ""
 346        one-level)))))
 347
 348 (defvar elmo-maildir-sequence-number-internal 0)
 349
 350 (static-cond
 351  ((>= emacs-major-version 19)
 352   (defun elmo-maildir-make-unique-string ()
 353     "This function generates a string that can be used as a unique
 354 file name for maildir directories."
 355      (let ((cur-time (current-time)))
 356        (format "%.0f.%d_%d.%s"
 357               (+ (* (car cur-time)
 358                     (float 65536)) (cadr cur-time))
 359               (emacs-pid)
 360               (incf elmo-maildir-sequence-number-internal)
 361               (system-name)))))
 362  ((eq emacs-major-version 18)
 363   ;; A fake function for v18
 364   (defun elmo-maildir-make-unique-string ()
 365     "This function generates a string that can be used as a unique
 366 file name for maildir directories."
 367     (unless (fboundp 'float-to-string)
 368       (load-library "float"))
 369     (let ((time (current-time)))
 370       (format "%s%d.%d.%s"
 371               (substring
 372                (float-to-string
 373                 (f+ (f* (f (car time))
 374                         (f 65536))
 375                     (f (cadr time))))
 376                0 5)
 377               (cadr time)
 378               (% (abs (random t)) 10000); dummy pid
 379               (system-name))))))
 380
 381 (defun elmo-maildir-temporal-filename (basedir)
 382   (let ((filename (expand-file-name
 383                    (concat "tmp/" (elmo-maildir-make-unique-string))
 384                    basedir)))
 385     (unless (file-exists-p (file-name-directory filename))
 386       (make-directory (file-name-directory filename)))
 387     (while (file-exists-p filename)
 388 ;;; I don't want to wait.
 389 ;;;   (sleep-for 2)
 390       (setq filename
 391             (expand-file-name
 392              (concat "tmp/" (elmo-maildir-make-unique-string))
 393              basedir)))
 394     filename))
 395
 396 (luna-define-method elmo-folder-append-buffer ((folder elmo-maildir-folder)
 397                                                &optional status number)
 398   (let ((basedir (elmo-maildir-folder-directory-internal folder))
 399         (src-buf (current-buffer))
 400         dst-buf filename)
 401     (condition-case nil
 402         (with-temp-buffer
 403           (setq filename (elmo-maildir-temporal-filename basedir))
 404           (setq dst-buf (current-buffer))
 405           (with-current-buffer src-buf
 406             (copy-to-buffer dst-buf (point-min) (point-max)))
 407           (as-binary-output-file
 408            (write-region (point-min) (point-max) filename nil 'no-msg))
 409           ;; add link from new.
 410           (elmo-add-name-to-file
 411            filename
 412            (expand-file-name
 413             (concat "new/" (file-name-nondirectory filename))
 414             basedir))
 415           t)
 416       ;; If an error occured, return nil.
 417       (error))))
 418
 419 (luna-define-method elmo-folder-message-file-p ((folder elmo-maildir-folder))
 420   t)
 421
 422 (luna-define-method elmo-message-file-name ((folder elmo-maildir-folder)
 423                                             number)
 424   (elmo-maildir-message-file-name
 425    folder
 426    (elmo-map-message-location folder number)))
 427
 428 (luna-define-method elmo-folder-message-make-temp-file-p
 429   ((folder elmo-maildir-folder))
 430   t)
 431
 432 (luna-define-method elmo-folder-message-make-temp-files ((folder
 433                                                           elmo-maildir-folder)
 434                                                          numbers
 435                                                          &optional
 436                                                          start-number)
 437   (let ((temp-dir (elmo-folder-make-temporary-directory folder))
 438         (cur-number (if start-number 0)))
 439     (dolist (number numbers)
 440       (elmo-copy-file
 441        (elmo-message-file-name folder number)
 442        (expand-file-name
 443         (int-to-string (if start-number (incf cur-number) number))
 444         temp-dir)))
 445     temp-dir))
 446
 447 (luna-define-method elmo-folder-append-messages :around
 448   ((folder elmo-maildir-folder)
 449    src-folder numbers &optional same-number)
 450   (if (elmo-folder-message-file-p src-folder)
 451       (let ((src-msgdb-exists (not (zerop (elmo-folder-length src-folder))))
 452             (dir (elmo-maildir-folder-directory-internal folder))
 453             (table (elmo-flag-table-load (elmo-folder-msgdb-path folder)))
 454             (succeeds numbers)
 455             filename flags id)
 456         (dolist (number numbers)
 457           (setq flags (elmo-message-flags src-folder (car numbers))
 458                 filename (elmo-maildir-temporal-filename dir))
 459           (elmo-copy-file
 460            (elmo-message-file-name src-folder number)
 461            filename)
 462           (elmo-add-name-to-file
 463            filename
 464            (expand-file-name
 465             (concat "new/" (file-name-nondirectory filename))
 466             dir))
 467           ;; src folder's msgdb is loaded.
 468           (when (setq id (and src-msgdb-exists
 469                               (elmo-message-field src-folder (car numbers)
 470                                                   'message-id)))
 471             (elmo-flag-table-set table id flags))
 472           (elmo-progress-notify 'elmo-folder-move-messages))
 473         (when (elmo-folder-persistent-p folder)
 474           (elmo-flag-table-save (elmo-folder-msgdb-path folder) table))
 475         succeeds)
 476     (luna-call-next-method)))
 477
 478 (luna-define-method elmo-map-folder-delete-messages
 479   ((folder elmo-maildir-folder) locations)
 480   (let (file)
 481     (dolist (location locations)
 482       (setq file (elmo-maildir-message-file-name folder location))
 483       (if (and file
 484                (file-writable-p file)
 485                (not (file-directory-p file)))
 486           (delete-file file)))))
 487
 488 (luna-define-method elmo-map-message-fetch ((folder elmo-maildir-folder)
 489                                             location strategy
 490                                             &optional section unseen)
 491   (let ((file (elmo-maildir-message-file-name folder location)))
 492     (when (file-exists-p file)
 493       (insert-file-contents-as-binary file))))
 494
 495 (luna-define-method elmo-folder-exists-p ((folder elmo-maildir-folder))
 496   (let ((basedir (elmo-maildir-folder-directory-internal folder)))
 497     (and (file-directory-p (expand-file-name "new" basedir))
 498          (file-directory-p (expand-file-name "cur" basedir))
 499          (file-directory-p (expand-file-name "tmp" basedir)))))
 500
 501 (luna-define-method elmo-folder-diff ((folder elmo-maildir-folder))
 502   (let* ((dir (elmo-maildir-folder-directory-internal folder))
 503          (new-len (length (car (elmo-maildir-list-location dir "new"))))
 504          (cur-len (length (car (elmo-maildir-list-location dir "cur")))))
 505     (cons new-len (+ new-len cur-len))))
 506
 507 (luna-define-method elmo-folder-creatable-p ((folder elmo-maildir-folder))
 508   t)
 509
 510 (luna-define-method elmo-folder-writable-p ((folder elmo-maildir-folder))
 511   t)
 512
 513 (luna-define-method elmo-folder-create ((folder elmo-maildir-folder))
 514   (let ((basedir (elmo-maildir-folder-directory-internal folder)))
 515     (condition-case nil
 516         (progn
 517           (dolist (dir '("." "new" "cur" "tmp"))
 518             (setq dir (expand-file-name dir basedir))
 519             (or (file-directory-p dir)
 520                 (progn
 521                   (elmo-make-directory dir)
 522                   (set-file-modes dir 448))))
 523           t)
 524       (error))))
 525
 526 (luna-define-method elmo-folder-delete ((folder elmo-maildir-folder))
 527   (let ((msgs (and (elmo-folder-exists-p folder)
 528                    (elmo-folder-list-messages folder))))
 529     (when (yes-or-no-p (format "%sDelete msgdb and substance of \"%s\"? "
 530                                (if (> (length msgs) 0)
 531                                    (format "%d msg(s) exists. " (length msgs))
 532                                  "")
 533                                (elmo-folder-name-internal folder)))
 534       (let ((basedir (elmo-maildir-folder-directory-internal folder)))
 535         (condition-case nil
 536             (let ((tmp-files (directory-files
 537                               (expand-file-name "tmp" basedir)
 538                               t "[^.].*")))
 539               ;; Delete files in tmp.
 540               (dolist (file tmp-files)
 541                 (delete-file file))
 542               (dolist (dir '("new" "cur" "tmp" "."))
 543                 (setq dir (expand-file-name dir basedir))
 544                 (if (not (file-directory-p dir))
 545                     (error nil)
 546                   (elmo-delete-directory dir t))))
 547           (error nil)))
 548       (elmo-msgdb-delete-path folder)
 549       t)))
 550
 551 (luna-define-method elmo-folder-rename-internal ((folder elmo-maildir-folder)
 552                                                  new-folder)
 553   (let* ((old (elmo-maildir-folder-directory-internal folder))
 554          (new (elmo-maildir-folder-directory-internal new-folder))
 555          (new-dir (directory-file-name (file-name-directory new))))
 556     (unless (file-directory-p old)
 557       (error "No such directory: %s" old))
 558     (when (file-exists-p new)
 559       (error "Already exists directory: %s" new))
 560     (unless (file-directory-p new-dir)
 561       (elmo-make-directory new-dir))
 562     (rename-file old new)
 563     t))
 564
 565 (require 'product)
 566 (product-provide (provide 'elmo-maildir) (require 'elmo-version))
 567
 568 ;;; elmo-maildir.el ends here