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