← Back to branch summary

~ubuntu-branches/ubuntu/saucy/wl/saucy-proposed

« back to all changes in this revision

Viewing changes to elmo/elmo-maildir.el

  • Committer: Bazaar Package Importer
  • Author(s): Takuo KITAME
  • Date: 2002-02-20 21:51:16 UTC
  • Revision ID: james.westby@ubuntu.com-20020220215116-htmbfdwsdr25nnhm
Tags: upstream-2.8.1
Import upstream version 2.8.1

Show diffs side-by-side

added added

removed removed

Lines of Context:
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-directory)))
 
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-temporary-directory 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
        (dolist (number numbers)
 
398
          (setq filename (elmo-maildir-temporal-filename dir))
 
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 :before ((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