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