* elmo.el (elmo-folder-list-flagged): New generic function.
[elisp/wanderlust.git] / elmo / elmo-shimbun.el
1 ;;; elmo-shimbun.el --- Shimbun interface for ELMO.
2
3 ;; Copyright (C) 2001 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 (require 'elmo)
32 (require 'elmo-map)
33 (require 'elmo-dop)
34 (require 'shimbun)
35
36 (defcustom elmo-shimbun-check-interval 60
37   "*Check interval for shimbun."
38   :type 'integer
39   :group 'elmo)
40
41 (defcustom elmo-shimbun-default-index-range 2
42   "*Default value for the range of header indices."
43   :type '(choice (const :tag "all" all)
44                  (const :tag "last" last)
45                  (integer :tag "number"))
46   :group 'elmo)
47
48 (defcustom elmo-shimbun-use-cache t
49   "*If non-nil, use cache for each article."
50   :type 'boolean
51   :group 'elmo)
52
53 (defcustom elmo-shimbun-index-range-alist nil
54   "*Alist of FOLDER-REGEXP and RANGE.
55 FOLDER-REGEXP is the regexp for shimbun folder name.
56 RANGE is the range of the header indices .
57 See `shimbun-headers' for more detail about RANGE."
58   :type '(repeat (cons (regexp :tag "Folder Regexp")
59                        (choice (const :tag "all" all)
60                                (const :tag "last" last)
61                                (integer :tag "number"))))
62   :group 'elmo)
63
64 (defcustom elmo-shimbun-update-overview-folder-list nil
65   "*List of FOLDER-REGEXP.
66 FOLDER-REGEXP is the regexp of shimbun folder name which should be
67 update overview when message is fetched."
68   :type '(repeat (regexp :tag "Folder Regexp"))
69   :group 'elmo)
70
71 ;; Shimbun header.
72 (defsubst elmo-shimbun-header-extra-field (header field-name)
73   (let ((extra (and header (shimbun-header-extra header))))
74     (and extra
75          (cdr (assoc field-name extra)))))
76
77 (defsubst elmo-shimbun-header-set-extra-field (header field-name value)
78   (let ((extras (and header (shimbun-header-extra header)))
79         extra)
80     (if (setq extra (assoc field-name extras))
81         (setcdr extra value)
82       (shimbun-header-set-extra
83        header
84        (cons (cons field-name value) extras)))))
85
86 ;; Shimbun mua.
87 (eval-and-compile
88   (luna-define-class shimbun-elmo-mua (shimbun-mua) (folder))
89   (luna-define-internal-accessors 'shimbun-elmo-mua))
90
91 (luna-define-method shimbun-mua-search-id ((mua shimbun-elmo-mua) id)
92   (elmo-msgdb-overview-get-entity id
93                                   (elmo-folder-msgdb
94                                    (shimbun-elmo-mua-folder-internal mua))))
95
96 (eval-and-compile
97   (luna-define-class elmo-shimbun-folder
98                      (elmo-map-folder) (shimbun headers header-hash
99                                                 entity-hash
100                                                 group range last-check))
101   (luna-define-internal-accessors 'elmo-shimbun-folder))
102
103 (defun elmo-shimbun-folder-entity-hash (folder)
104   (or (elmo-shimbun-folder-entity-hash-internal folder)
105       (let ((overviews (elmo-msgdb-get-overview (elmo-folder-msgdb folder)))
106             hash id)
107         (when overviews
108           (setq hash (elmo-make-hash (length overviews)))
109           (dolist (entity overviews)
110             (elmo-set-hash-val (elmo-msgdb-overview-entity-get-id entity)
111                                entity hash)
112             (when (setq id (elmo-msgdb-overview-entity-get-extra-field
113                             entity "x-original-id"))
114               (elmo-set-hash-val id entity hash)))
115           (elmo-shimbun-folder-set-entity-hash-internal folder hash)))))
116
117 (defsubst elmo-shimbun-folder-shimbun-header (folder location)
118   (let ((hash (elmo-shimbun-folder-header-hash-internal folder)))
119     (or (and hash (elmo-get-hash-val location hash))
120         (let ((entity (elmo-msgdb-overview-get-entity
121                        location
122                        (elmo-folder-msgdb folder)))
123               (elmo-hash-minimum-size 63)
124               header)
125           (when entity
126             (setq header (elmo-shimbun-entity-to-header entity))
127             (unless hash
128               (elmo-shimbun-folder-set-header-hash-internal
129                folder
130                (setq hash (elmo-make-hash))))
131             (elmo-set-hash-val (elmo-msgdb-overview-entity-get-id entity)
132                                header
133                                hash)
134             header)))))
135
136 (defsubst elmo-shimbun-lapse-seconds (time)
137   (let ((now (current-time)))
138     (+ (* (- (car now) (car time)) 65536)
139        (- (nth 1 now) (nth 1 time)))))
140
141 (defun elmo-shimbun-parse-time-string (string)
142   "Parse the time-string STRING and return its time as Emacs style."
143   (ignore-errors
144     (let ((x (timezone-fix-time string nil nil)))
145       (encode-time (aref x 5) (aref x 4) (aref x 3)
146                    (aref x 2) (aref x 1) (aref x 0)
147                    (aref x 6)))))
148
149 (defsubst elmo-shimbun-headers-check-p (folder)
150   (or (null (elmo-shimbun-folder-last-check-internal folder))
151       (and (elmo-shimbun-folder-last-check-internal folder)
152            (> (elmo-shimbun-lapse-seconds
153                (elmo-shimbun-folder-last-check-internal folder))
154               elmo-shimbun-check-interval))))
155
156 (defun elmo-shimbun-entity-to-header (entity)
157   (let (message-id shimbun-id)
158     (if (setq message-id (elmo-msgdb-overview-entity-get-extra-field
159                           entity "x-original-id"))
160         (setq shimbun-id (elmo-msgdb-overview-entity-get-id entity))
161       (setq message-id (elmo-msgdb-overview-entity-get-id entity)
162             shimbun-id nil))
163     (elmo-set-work-buf
164      (set-buffer-multibyte t)
165      (shimbun-make-header
166       (elmo-msgdb-overview-entity-get-number entity)
167       (shimbun-mime-encode-string
168        (decode-mime-charset-string
169         (elmo-msgdb-overview-entity-get-subject-no-decode entity)
170         elmo-mime-charset))
171       (shimbun-mime-encode-string
172        (decode-mime-charset-string
173         (elmo-msgdb-overview-entity-get-from-no-decode entity)
174         elmo-mime-charset))
175       (elmo-msgdb-overview-entity-get-date entity)
176       message-id
177       (elmo-msgdb-overview-entity-get-references entity)
178       0
179       0
180       (elmo-msgdb-overview-entity-get-extra-field entity "xref")
181       (and shimbun-id
182            (list (cons "x-shimbun-id" shimbun-id)))))))
183
184 (defsubst elmo-shimbun-folder-header-hash-setup (folder headers)
185   (let ((hash (or (elmo-shimbun-folder-header-hash-internal folder)
186                   (elmo-make-hash (length headers)))))
187     (dolist (header headers)
188       (elmo-set-hash-val (shimbun-header-id header) header hash))
189     (elmo-shimbun-folder-set-header-hash-internal folder hash)))
190
191 (defun elmo-shimbun-get-headers (folder)
192   (let* ((shimbun (elmo-shimbun-folder-shimbun-internal folder))
193          (key (concat (shimbun-server-internal shimbun)
194                       "." (shimbun-current-group-internal shimbun)))
195          (elmo-hash-minimum-size 63)
196          headers)
197     ;; new headers.
198     (setq headers
199           (delq nil
200                 (mapcar
201                  (lambda (x)
202                    (unless (elmo-msgdb-overview-get-entity
203                             (shimbun-header-id x)
204                             (elmo-folder-msgdb folder))
205                      x))
206                  ;; This takes much time.
207                  (shimbun-headers
208                   (elmo-shimbun-folder-shimbun-internal folder)
209                   (elmo-shimbun-folder-range-internal folder)))))
210     (elmo-shimbun-folder-set-headers-internal folder headers)
211     (when headers
212       (elmo-shimbun-folder-header-hash-setup folder headers))
213     (elmo-shimbun-folder-set-last-check-internal folder (current-time))))
214
215 (luna-define-method elmo-folder-initialize ((folder
216                                              elmo-shimbun-folder)
217                                             name)
218   (let ((server-group (if (string-match "\\([^.]+\\)\\." name)
219                           (list (elmo-match-string 1 name)
220                                 (substring name (match-end 0)))
221                         (list name))))
222     (when (nth 0 server-group) ; server
223       (elmo-shimbun-folder-set-shimbun-internal
224        folder
225        (shimbun-open (nth 0 server-group)
226                      (luna-make-entity 'shimbun-elmo-mua :folder folder))))
227     (when (nth 1 server-group)
228       (elmo-shimbun-folder-set-group-internal
229        folder
230        (nth 1 server-group)))
231     (elmo-shimbun-folder-set-range-internal
232      folder
233      (or (cdr (elmo-string-matched-assoc (elmo-folder-name-internal folder)
234                                          elmo-shimbun-index-range-alist))
235          elmo-shimbun-default-index-range))
236     folder))
237
238 (luna-define-method elmo-folder-open-internal ((folder elmo-shimbun-folder))
239   (shimbun-open-group
240    (elmo-shimbun-folder-shimbun-internal folder)
241    (elmo-shimbun-folder-group-internal folder))
242   (let ((inhibit-quit t))
243     (unless (elmo-map-folder-location-alist-internal folder)
244       (elmo-map-folder-location-setup
245        folder
246        (elmo-msgdb-location-load (elmo-folder-msgdb-path folder))))
247     (when (and (elmo-folder-plugged-p folder)
248                (elmo-shimbun-headers-check-p folder))
249       (elmo-shimbun-get-headers folder)
250       (elmo-map-folder-update-locations
251        folder
252        (elmo-map-folder-list-message-locations folder)))))
253
254 (luna-define-method elmo-folder-reserve-status-p ((folder elmo-shimbun-folder))
255   t)
256
257 (luna-define-method elmo-folder-local-p ((folder elmo-shimbun-folder))
258   nil)
259
260 (luna-define-method elmo-message-use-cache-p ((folder elmo-shimbun-folder)
261                                               number)
262   elmo-shimbun-use-cache)
263
264 (luna-define-method elmo-folder-close-internal :after ((folder
265                                                         elmo-shimbun-folder))
266   (shimbun-close-group
267    (elmo-shimbun-folder-shimbun-internal folder))
268   (elmo-shimbun-folder-set-headers-internal
269    folder nil)
270   (elmo-shimbun-folder-set-header-hash-internal
271    folder nil)
272   (elmo-shimbun-folder-set-entity-hash-internal
273    folder nil)
274   (elmo-shimbun-folder-set-last-check-internal
275    folder nil))
276
277 (luna-define-method elmo-folder-plugged-p ((folder elmo-shimbun-folder))
278   (elmo-plugged-p
279    "shimbun"
280    (shimbun-server-internal (elmo-shimbun-folder-shimbun-internal folder))
281    nil nil
282    (shimbun-server-internal (elmo-shimbun-folder-shimbun-internal folder))))
283
284 (luna-define-method elmo-folder-set-plugged ((folder elmo-shimbun-folder)
285                                              plugged &optional add)
286   (elmo-set-plugged plugged
287                     "shimbun"
288                     (shimbun-server-internal
289                      (elmo-shimbun-folder-shimbun-internal folder))
290                     nil nil nil
291                     (shimbun-server-internal
292                      (elmo-shimbun-folder-shimbun-internal folder))
293                     add))
294
295 (luna-define-method elmo-net-port-info ((folder elmo-shimbun-folder))
296   (list "shimbun"
297         (shimbun-server-internal
298          (elmo-shimbun-folder-shimbun-internal folder))
299         nil))
300
301 (luna-define-method elmo-folder-check :around ((folder elmo-shimbun-folder))
302   (when (shimbun-current-group-internal
303          (elmo-shimbun-folder-shimbun-internal folder))
304     (when (and (elmo-folder-plugged-p folder)
305                (elmo-shimbun-headers-check-p folder))
306       (elmo-shimbun-get-headers folder)
307       (luna-call-next-method))))
308
309 (luna-define-method elmo-folder-clear :around ((folder elmo-shimbun-folder)
310                                                &optional keep-killed)
311   (elmo-shimbun-folder-set-headers-internal folder nil)
312   (elmo-shimbun-folder-set-header-hash-internal folder nil)
313   (elmo-shimbun-folder-set-entity-hash-internal folder nil)
314   (elmo-shimbun-folder-set-last-check-internal folder nil)
315   (luna-call-next-method))
316
317 (luna-define-method elmo-folder-expand-msgdb-path ((folder
318                                                     elmo-shimbun-folder))
319   (expand-file-name
320    (concat (shimbun-server-internal
321             (elmo-shimbun-folder-shimbun-internal folder))
322            "/"
323            (elmo-shimbun-folder-group-internal folder))
324    (expand-file-name "shimbun" elmo-msgdb-directory)))
325
326 (defun elmo-shimbun-msgdb-create-entity (folder number)
327   (let ((header (elmo-shimbun-folder-shimbun-header
328                  folder
329                  (elmo-map-message-location folder number)))
330         ov)
331     (when header
332       (with-temp-buffer
333         (shimbun-header-insert
334          (elmo-shimbun-folder-shimbun-internal folder)
335          header)
336         (setq ov (elmo-msgdb-create-overview-from-buffer number))
337         (elmo-msgdb-overview-entity-set-extra
338          ov
339          (nconc
340           (elmo-msgdb-overview-entity-get-extra ov)
341           (list (cons "xref" (shimbun-header-xref header)))))))))
342
343 (luna-define-method elmo-folder-msgdb-create ((folder elmo-shimbun-folder)
344                                               numlist seen-list)
345   (let* (overview number-alist mark-alist entity
346                   i percent number length pair msgid gmark seen)
347     (setq length (length numlist))
348     (setq i 0)
349     (message "Creating msgdb...")
350     (while numlist
351       (setq entity
352             (elmo-shimbun-msgdb-create-entity
353              folder (car numlist)))
354       (when entity
355         (setq overview
356               (elmo-msgdb-append-element
357                overview entity))
358         (setq number (elmo-msgdb-overview-entity-get-number entity))
359         (setq msgid (elmo-msgdb-overview-entity-get-id entity))
360         (setq number-alist
361               (elmo-msgdb-number-add number-alist
362                                      number msgid))
363         (setq seen (member msgid seen-list))
364         (if (setq gmark (or (elmo-msgdb-global-mark-get msgid)
365                             (if (elmo-file-cache-status
366                                  (elmo-file-cache-get msgid))
367                                 (if seen nil elmo-msgdb-unread-cached-mark)
368                               (if seen
369                                   (if elmo-shimbun-use-cache
370                                       elmo-msgdb-read-uncached-mark)
371                                 elmo-msgdb-new-mark))))
372             (setq mark-alist
373                   (elmo-msgdb-mark-append mark-alist
374                                           number gmark))))
375       (when (> length elmo-display-progress-threshold)
376         (setq i (1+ i))
377         (setq percent (/ (* i 100) length))
378         (elmo-display-progress
379          'elmo-folder-msgdb-create "Creating msgdb..."
380          percent))
381       (setq numlist (cdr numlist)))
382     (message "Creating msgdb...done.")
383     (elmo-msgdb-sort-by-date
384      (list overview number-alist mark-alist))))
385
386 (luna-define-method elmo-folder-message-file-p ((folder elmo-shimbun-folder))
387   nil)
388
389 (defsubst elmo-shimbun-update-overview (folder shimbun-id header)
390   (let ((entity (elmo-msgdb-overview-get-entity shimbun-id
391                                                 (elmo-folder-msgdb folder)))
392         (message-id (shimbun-header-id header))
393         references)
394     (unless (string= shimbun-id message-id)
395       (elmo-msgdb-overview-entity-set-extra-field
396        entity "x-original-id" message-id)
397       (elmo-shimbun-header-set-extra-field
398        header "x-shimbun-id" shimbun-id)
399       (elmo-set-hash-val message-id
400                          entity
401                          (elmo-shimbun-folder-entity-hash folder))
402       (elmo-set-hash-val shimbun-id
403                          entity
404                          (elmo-shimbun-folder-entity-hash folder)))
405     (elmo-msgdb-overview-entity-set-from
406      entity
407      (elmo-mime-string (shimbun-header-from header)))
408     (elmo-msgdb-overview-entity-set-subject
409      entity
410      (elmo-mime-string (shimbun-header-subject header)))
411     (elmo-msgdb-overview-entity-set-date
412      entity (shimbun-header-date header))
413     (when (setq references
414                 (or (elmo-msgdb-get-last-message-id
415                      (elmo-field-body "in-reply-to"))
416                     (elmo-msgdb-get-last-message-id
417                      (elmo-field-body "references"))))
418       (elmo-msgdb-overview-entity-set-references
419        entity
420        (or (elmo-msgdb-overview-entity-get-id
421             (elmo-get-hash-val
422              references
423              (elmo-shimbun-folder-entity-hash folder)))
424            references)))))
425
426 (luna-define-method elmo-map-message-fetch ((folder elmo-shimbun-folder)
427                                             location strategy
428                                             &optional section unseen)
429   (if (elmo-folder-plugged-p folder)
430       (let ((header (elmo-shimbun-folder-shimbun-header
431                      folder
432                      location))
433             shimbun-id)
434         (shimbun-article (elmo-shimbun-folder-shimbun-internal folder)
435                          header)
436         (when (elmo-string-match-member
437                (elmo-folder-name-internal folder)
438                elmo-shimbun-update-overview-folder-list)
439           (elmo-shimbun-update-overview folder location header))
440         (when (setq shimbun-id
441                     (elmo-shimbun-header-extra-field header "x-shimbun-id"))
442           (goto-char (point-min))
443           (insert (format "X-Shimbun-Id: %s\n" shimbun-id)))
444         t)
445     (error "Unplugged")))
446
447 (luna-define-method elmo-message-encache :around ((folder
448                                                    elmo-shimbun-folder)
449                                                   number &optional read)
450   (if (elmo-folder-plugged-p folder)
451       (luna-call-next-method)
452     (if elmo-enable-disconnected-operation
453         (elmo-message-encache-dop folder number read)
454       (error "Unplugged"))))
455
456 (luna-define-method elmo-folder-list-messages-internal :around
457   ((folder elmo-shimbun-folder) &optional nohide)
458   (if (elmo-folder-plugged-p folder)
459       (luna-call-next-method)
460     t))
461
462 (luna-define-method elmo-map-folder-list-message-locations
463   ((folder elmo-shimbun-folder))
464   (let ((expire-days (shimbun-article-expiration-days
465                       (elmo-shimbun-folder-shimbun-internal folder))))
466     (elmo-uniq-list
467      (nconc
468       (delq nil
469             (mapcar
470              (lambda (ov)
471                (when (and (elmo-msgdb-overview-entity-get-extra-field
472                            ov "xref")
473                           (if expire-days
474                               (< (elmo-shimbun-lapse-seconds
475                                   (elmo-shimbun-parse-time-string
476                                    (elmo-msgdb-overview-entity-get-date ov)))
477                                  (* expire-days 86400 ; seconds per day
478                                     ))
479                             t))
480                  (elmo-msgdb-overview-entity-get-id ov)))
481              (elmo-msgdb-get-overview (elmo-folder-msgdb folder))))
482       (mapcar
483        (lambda (header)
484          (or (elmo-shimbun-header-extra-field header "x-shimbun-id")
485              (shimbun-header-id header)))
486        (elmo-shimbun-folder-headers-internal folder))))))
487
488 (luna-define-method elmo-folder-list-subfolders ((folder elmo-shimbun-folder)
489                                                  &optional one-level)
490   (unless (elmo-shimbun-folder-group-internal folder)
491     (mapcar
492      (lambda (x)
493        (concat (elmo-folder-prefix-internal folder)
494                (shimbun-server-internal
495                 (elmo-shimbun-folder-shimbun-internal folder))
496                "."
497                x))
498      (shimbun-groups (elmo-shimbun-folder-shimbun-internal folder)))))
499
500 (luna-define-method elmo-folder-exists-p ((folder elmo-shimbun-folder))
501   (if (elmo-shimbun-folder-group-internal folder)
502       (progn
503         (member
504          (elmo-shimbun-folder-group-internal folder)
505          (shimbun-groups (elmo-shimbun-folder-shimbun-internal
506                           folder))))
507     t))
508
509 (require 'product)
510 (product-provide (provide 'elmo-shimbun) (require 'elmo-version))
511
512 ;;; elmo-shimbun.el ends here