New feature: toggle visibility of mime buttons.
[more-wl.git] / elmo / elmo-shimbun.el
blob889280ae20291b7a6a1489e8d42bce2fb2ea573f
1 ;;; elmo-shimbun.el --- Shimbun interface for ELMO.
3 ;; Copyright (C) 2001 Yuuichi Teranishi <teranisi@gohome.org>
5 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
6 ;; Keywords: mail, net news
8 ;; This file is part of ELMO (Elisp Library for Message Orchestration).
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.
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.
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.
26 ;;; Commentary:
29 ;;; Code:
31 (require 'elmo)
32 (require 'elmo-map)
33 (require 'elmo-dop)
34 (require 'shimbun)
36 (eval-when-compile
37 (require 'cl)
38 (defun-maybe shimbun-servers-list ()))
40 (defcustom elmo-shimbun-check-interval 60
41 "*Check interval for shimbun."
42 :type 'integer
43 :group 'elmo)
45 (defcustom elmo-shimbun-default-index-range 2
46 "*Default value for the range of header indices."
47 :type '(choice (const :tag "all" all)
48 (const :tag "last" last)
49 (integer :tag "number"))
50 :group 'elmo)
52 (defcustom elmo-shimbun-use-cache t
53 "*If non-nil, use cache for each article."
54 :type 'boolean
55 :group 'elmo)
57 (defcustom elmo-shimbun-index-range-alist nil
58 "*Alist of FOLDER-REGEXP and RANGE.
59 FOLDER-REGEXP is the regexp for shimbun folder name.
60 RANGE is the range of the header indices .
61 See `shimbun-headers' for more detail about RANGE."
62 :type '(repeat (cons (regexp :tag "Folder Regexp")
63 (choice (const :tag "all" all)
64 (const :tag "last" last)
65 (integer :tag "number"))))
66 :group 'elmo)
68 (defcustom elmo-shimbun-update-overview-folder-list 'all
69 "*List of FOLDER-REGEXP.
70 FOLDER-REGEXP is the regexp of shimbun folder name which should be
71 update overview when message is fetched.
72 If it is the symbol `all', update overview for all shimbun folders."
73 :type '(choice (const :tag "All shimbun folders" all)
74 (repeat (regexp :tag "Folder Regexp")))
75 :group 'elmo)
77 ;; Shimbun header.
78 (defsubst elmo-shimbun-header-extra-field (header field-name)
79 (let ((extra (and header (shimbun-header-extra header))))
80 (and extra
81 (cdr (assoc field-name extra)))))
83 (defsubst elmo-shimbun-header-set-extra-field (header field-name value)
84 (let ((extras (and header (shimbun-header-extra header)))
85 extra)
86 (if (setq extra (assoc field-name extras))
87 (setcdr extra value)
88 (shimbun-header-set-extra
89 header
90 (cons (cons field-name value) extras)))))
92 ;; Shimbun mua.
93 (eval-and-compile
94 (luna-define-class shimbun-elmo-mua (shimbun-mua) (folder))
95 (luna-define-internal-accessors 'shimbun-elmo-mua))
97 (luna-define-method shimbun-mua-search-id ((mua shimbun-elmo-mua) id)
98 (elmo-message-entity (shimbun-elmo-mua-folder-internal mua) id))
100 (eval-and-compile
101 (luna-define-class elmo-shimbun-folder
102 (elmo-map-folder) (shimbun headers header-hash
103 entity-hash
104 group range last-check))
105 (luna-define-internal-accessors 'elmo-shimbun-folder))
107 (defun elmo-shimbun-folder-entity-hash (folder)
108 (or (elmo-shimbun-folder-entity-hash-internal folder)
109 (let ((overviews (elmo-folder-list-message-entities folder))
110 hash id)
111 (when overviews
112 (setq hash (elmo-make-hash (length overviews)))
113 (dolist (entity overviews)
114 (elmo-set-hash-val (elmo-message-entity-field entity 'message-id)
115 entity hash)
116 (when (setq id (elmo-message-entity-field entity 'x-original-id))
117 (elmo-set-hash-val id entity hash)))
118 (elmo-shimbun-folder-set-entity-hash-internal folder hash)))))
120 (defsubst elmo-shimbun-folder-shimbun-header (folder location)
121 (let ((hash (elmo-shimbun-folder-header-hash-internal folder)))
122 (or (and hash (elmo-get-hash-val location hash))
123 (let ((entity (elmo-message-entity folder location))
124 (elmo-hash-minimum-size 63)
125 header)
126 (when entity
127 (setq header (elmo-shimbun-entity-to-header entity))
128 (unless hash
129 (elmo-shimbun-folder-set-header-hash-internal
130 folder
131 (setq hash (elmo-make-hash))))
132 (elmo-set-hash-val (elmo-message-entity-field entity 'message-id)
133 header
134 hash)
135 header)))))
137 (defsubst elmo-shimbun-lapse-seconds (time)
138 (let ((now (current-time)))
139 (+ (* (- (car now) (car time)) 65536)
140 (- (nth 1 now) (nth 1 time)))))
142 (defsubst elmo-shimbun-headers-check-p (folder)
143 (or (null (elmo-shimbun-folder-last-check-internal folder))
144 (and (elmo-shimbun-folder-last-check-internal folder)
145 (> (elmo-shimbun-lapse-seconds
146 (elmo-shimbun-folder-last-check-internal folder))
147 elmo-shimbun-check-interval))))
149 (defun elmo-shimbun-entity-to-header (entity)
150 (let (message-id shimbun-id)
151 (if (setq message-id (elmo-message-entity-field entity 'x-original-id))
152 (setq shimbun-id (elmo-message-entity-field entity 'message-id))
153 (setq message-id (elmo-message-entity-field entity 'message-id)
154 shimbun-id nil))
155 (elmo-with-enable-multibyte
156 (shimbun-create-header
157 (elmo-message-entity-number entity)
158 (elmo-message-entity-field entity 'subject)
159 (elmo-message-entity-field entity 'from)
160 (elmo-time-make-date-string
161 (elmo-message-entity-field entity 'date))
162 message-id
163 (elmo-message-entity-field entity 'references)
164 (elmo-message-entity-field entity 'size)
166 (elmo-message-entity-field entity 'xref)
167 (and shimbun-id
168 (list (cons "x-shimbun-id" shimbun-id)))))))
170 (defsubst elmo-shimbun-folder-header-hash-setup (folder headers)
171 (let ((hash (or (elmo-shimbun-folder-header-hash-internal folder)
172 (elmo-make-hash (length headers)))))
173 (dolist (header headers)
174 (elmo-set-hash-val (shimbun-header-id header) header hash))
175 (elmo-shimbun-folder-set-header-hash-internal folder hash)))
177 (defun elmo-shimbun-get-headers (folder)
178 (let* ((shimbun (elmo-shimbun-folder-shimbun-internal folder))
179 (key (concat (shimbun-server shimbun)
180 "." (shimbun-current-group shimbun)))
181 (elmo-hash-minimum-size 63)
182 headers)
183 ;; new headers.
184 (setq headers
185 (delq nil
186 (mapcar
187 (lambda (x)
188 (unless (elmo-message-entity folder (shimbun-header-id 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 folder headers)
195 (when headers
196 (elmo-shimbun-folder-header-hash-setup folder headers))
197 (elmo-shimbun-folder-set-last-check-internal folder (current-time))))
199 (luna-define-method elmo-folder-initialize ((folder
200 elmo-shimbun-folder)
201 name)
202 (if (string= name "")
203 folder
204 (let ((server-group (if (string-match "\\([^.]+\\)\\." name)
205 (list (elmo-match-string 1 name)
206 (substring name (match-end 0)))
207 (list name))))
208 (when (nth 0 server-group) ; server
209 (elmo-shimbun-folder-set-shimbun-internal
210 folder
211 (condition-case nil
212 (shimbun-open (nth 0 server-group)
213 (luna-make-entity 'shimbun-elmo-mua :folder folder))
214 (file-error
215 (luna-make-entity 'shimbun :server (nth 0 server-group))))))
216 (when (nth 1 server-group)
217 (elmo-shimbun-folder-set-group-internal
218 folder
219 (nth 1 server-group)))
220 (elmo-shimbun-folder-set-range-internal
221 folder
222 (or (cdr (elmo-string-matched-assoc (elmo-folder-name-internal folder)
223 elmo-shimbun-index-range-alist))
224 elmo-shimbun-default-index-range))
225 folder)))
227 (luna-define-method elmo-folder-open-internal ((folder elmo-shimbun-folder))
228 (when (elmo-shimbun-folder-shimbun-internal 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-location-map-alist folder)
234 (elmo-location-map-setup
235 folder
236 (elmo-msgdb-location-load (elmo-folder-msgdb-path folder))))
237 (when (and (elmo-folder-plugged-p folder)
238 (elmo-shimbun-headers-check-p folder))
239 (elmo-shimbun-get-headers folder)
240 (elmo-location-map-update
241 folder
242 (elmo-map-folder-list-message-locations folder))))))
244 (luna-define-method elmo-folder-reserve-status-p ((folder elmo-shimbun-folder))
247 (luna-define-method elmo-folder-local-p ((folder elmo-shimbun-folder))
248 nil)
250 (luna-define-method elmo-message-use-cache-p ((folder elmo-shimbun-folder)
251 number)
252 elmo-shimbun-use-cache)
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-entity-hash-internal
263 folder nil)
264 (elmo-shimbun-folder-set-last-check-internal
265 folder nil))
267 (luna-define-method elmo-folder-plugged-p ((folder elmo-shimbun-folder))
268 (if (elmo-shimbun-folder-shimbun-internal folder)
269 (elmo-plugged-p
270 "shimbun"
271 (shimbun-server (elmo-shimbun-folder-shimbun-internal folder))
272 nil nil
273 (shimbun-server (elmo-shimbun-folder-shimbun-internal folder)))
276 (luna-define-method elmo-folder-set-plugged ((folder elmo-shimbun-folder)
277 plugged &optional add)
278 (elmo-set-plugged plugged
279 "shimbun"
280 (shimbun-server
281 (elmo-shimbun-folder-shimbun-internal folder))
282 nil nil nil
283 (shimbun-server
284 (elmo-shimbun-folder-shimbun-internal folder))
285 add))
287 (luna-define-method elmo-net-port-info ((folder elmo-shimbun-folder))
288 (list "shimbun"
289 (shimbun-server
290 (elmo-shimbun-folder-shimbun-internal folder))
291 nil))
293 (luna-define-method elmo-folder-check :around ((folder elmo-shimbun-folder))
294 (when (shimbun-current-group
295 (elmo-shimbun-folder-shimbun-internal folder))
296 (when (and (elmo-folder-plugged-p folder)
297 (elmo-shimbun-headers-check-p folder))
298 (elmo-shimbun-get-headers folder)
299 (luna-call-next-method))))
301 (luna-define-method elmo-folder-clear :around ((folder elmo-shimbun-folder)
302 &optional keep-killed)
303 (elmo-shimbun-folder-set-headers-internal folder nil)
304 (elmo-shimbun-folder-set-header-hash-internal folder nil)
305 (elmo-shimbun-folder-set-entity-hash-internal folder nil)
306 (elmo-shimbun-folder-set-last-check-internal folder nil)
307 (luna-call-next-method))
309 (luna-define-method elmo-folder-expand-msgdb-path ((folder
310 elmo-shimbun-folder))
311 (expand-file-name
312 (concat (shimbun-server
313 (elmo-shimbun-folder-shimbun-internal folder))
315 (elmo-shimbun-folder-group-internal folder))
316 (expand-file-name "shimbun" elmo-msgdb-directory)))
318 (defun elmo-shimbun-msgdb-create-entity (folder number)
319 (let ((header (elmo-shimbun-folder-shimbun-header
320 folder
321 (elmo-map-message-location folder number)))
323 (when header
324 (with-temp-buffer
325 (shimbun-header-insert
326 (elmo-shimbun-folder-shimbun-internal folder)
327 header)
328 (setq ov (elmo-msgdb-create-message-entity-from-buffer
329 (elmo-msgdb-message-entity-handler
330 (elmo-folder-msgdb-internal folder)) number))
331 (elmo-message-entity-set-field
333 'xref (shimbun-header-xref header)))
334 ov)))
336 (luna-define-method elmo-folder-msgdb-create ((folder elmo-shimbun-folder)
337 numlist flag-table)
338 (let ((new-msgdb (elmo-make-msgdb))
339 entity msgid flags)
340 (elmo-with-progress-display (elmo-folder-msgdb-create (length numlist))
341 "Creating msgdb"
342 (dolist (number numlist)
343 (setq entity (elmo-shimbun-msgdb-create-entity folder number))
344 (when entity
345 (setq msgid (elmo-message-entity-field entity 'message-id)
346 flags (elmo-flag-table-get flag-table msgid))
347 (elmo-global-flags-set flags folder number msgid)
348 (elmo-msgdb-append-entity new-msgdb entity flags))
349 (elmo-progress-notify 'elmo-folder-msgdb-create)))
350 new-msgdb))
352 (luna-define-method elmo-folder-message-file-p ((folder elmo-shimbun-folder))
353 nil)
355 (defsubst elmo-shimbun-update-overview (folder entity shimbun-id header)
356 (let ((message-id (shimbun-header-id header))
357 references)
358 (when (elmo-msgdb-update-entity
359 (elmo-folder-msgdb folder)
360 entity
361 (nconc
362 (unless (string= shimbun-id message-id)
363 (elmo-shimbun-header-set-extra-field
364 header "x-shimbun-id" shimbun-id)
365 (elmo-set-hash-val message-id
366 entity
367 (elmo-shimbun-folder-entity-hash folder))
368 (elmo-set-hash-val shimbun-id
369 entity
370 (elmo-shimbun-folder-entity-hash folder))
371 (list (cons 'x-original-id message-id)))
372 (list
373 (cons 'from (shimbun-header-from header 'no-encode))
374 (cons 'subject (shimbun-header-subject header 'no-encode))
375 (cons 'date (shimbun-header-date header))
376 (cons 'references
377 (elmo-msgdb-get-references-from-buffer)))))
378 (elmo-emit-signal 'update-overview folder
379 (elmo-message-entity-number entity)))))
381 (luna-define-method elmo-map-message-fetch ((folder elmo-shimbun-folder)
382 location strategy
383 &optional section unseen)
384 (if (elmo-folder-plugged-p folder)
385 (let ((header (elmo-shimbun-folder-shimbun-header
386 folder
387 location))
388 shimbun-id)
389 (shimbun-article (elmo-shimbun-folder-shimbun-internal folder)
390 header)
391 (when (or (eq elmo-shimbun-update-overview-folder-list 'all)
392 (elmo-string-match-member
393 (elmo-folder-name-internal folder)
394 elmo-shimbun-update-overview-folder-list))
395 (let ((entity (elmo-message-entity folder location)))
396 (when entity
397 (elmo-shimbun-update-overview folder entity location header))))
398 (when (setq shimbun-id
399 (elmo-shimbun-header-extra-field header "x-shimbun-id"))
400 (goto-char (point-min))
401 (insert (format "X-Shimbun-Id: %s\n" shimbun-id)))
403 (error "Unplugged")))
405 (luna-define-method elmo-message-encache :around ((folder
406 elmo-shimbun-folder)
407 number &optional read)
408 (if (elmo-folder-plugged-p folder)
409 (luna-call-next-method)
410 (if elmo-enable-disconnected-operation
411 (elmo-message-encache-dop folder number read)
412 (error "Unplugged"))))
414 (luna-define-method elmo-folder-list-messages-internal :around
415 ((folder elmo-shimbun-folder) &optional nohide)
416 (if (elmo-folder-plugged-p folder)
417 (luna-call-next-method)
420 (luna-define-method elmo-map-folder-list-message-locations
421 ((folder elmo-shimbun-folder))
422 (let ((expire-days (shimbun-article-expiration-days
423 (elmo-shimbun-folder-shimbun-internal folder))))
424 (elmo-uniq-list
425 (nconc
426 (delq nil
427 (mapcar
428 (lambda (ov)
429 (when (and (elmo-message-entity-field ov 'xref)
430 (if expire-days
431 (< (elmo-shimbun-lapse-seconds
432 (elmo-message-entity-field ov 'date))
433 (* expire-days 86400 ; seconds per day
436 (elmo-message-entity-field ov 'message-id)))
437 (elmo-folder-list-message-entities folder)))
438 (mapcar
439 (lambda (header)
440 (or (elmo-shimbun-header-extra-field header "x-shimbun-id")
441 (shimbun-header-id header)))
442 (elmo-shimbun-folder-headers-internal folder))))))
444 (luna-define-method elmo-folder-list-subfolders ((folder elmo-shimbun-folder)
445 &optional one-level)
446 (let ((prefix (elmo-folder-prefix-internal folder)))
447 (cond ((elmo-shimbun-folder-shimbun-internal folder)
448 (unless (elmo-shimbun-folder-group-internal folder)
449 (mapcar
450 (lambda (fld)
451 (concat prefix
452 (shimbun-server
453 (elmo-shimbun-folder-shimbun-internal folder))
454 "." fld))
455 (shimbun-groups (elmo-shimbun-folder-shimbun-internal folder)))))
456 ;; the rest are for "@/" group
457 (one-level
458 (mapcar
459 (lambda (server) (list (concat prefix server)))
460 (shimbun-servers-list)))
462 (let (folders)
463 (dolist (server (shimbun-servers-list))
464 (setq folders
465 (append folders
466 (mapcar
467 (lambda (group) (concat prefix server "." group))
468 (shimbun-groups
469 (elmo-shimbun-folder-shimbun-internal
470 (elmo-get-folder (concat prefix server))))))))
471 folders)))))
473 (luna-define-method elmo-folder-exists-p ((folder elmo-shimbun-folder))
474 (if (elmo-shimbun-folder-group-internal folder)
475 (if (fboundp 'shimbun-group-p)
476 (shimbun-group-p (elmo-shimbun-folder-shimbun-internal folder)
477 (elmo-shimbun-folder-group-internal folder))
478 (member
479 (elmo-shimbun-folder-group-internal folder)
480 (shimbun-groups (elmo-shimbun-folder-shimbun-internal folder))))
483 (luna-define-method elmo-folder-delete-messages ((folder elmo-shimbun-folder)
484 numbers)
485 (elmo-folder-kill-messages folder numbers)
488 (luna-define-method elmo-message-entity-parent ((folder elmo-shimbun-folder)
489 entity)
490 (let ((references (elmo-message-entity-field entity 'references)))
491 (and references
492 (elmo-get-hash-val references
493 (elmo-shimbun-folder-entity-hash folder)))))
495 (require 'product)
496 (product-provide (provide 'elmo-shimbun) (require 'elmo-version))
498 ;;; elmo-shimbun.el ends here