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)
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.
38 (defun-maybe shimbun-servers-list ()))
40 (defcustom elmo-shimbun-check-interval 60
41 "*Check interval for shimbun."
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"))
52 (defcustom elmo-shimbun-use-cache t
53 "*If non-nil, use cache for each article."
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"))))
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")))
78 (defsubst elmo-shimbun-header-extra-field (header field-name)
79 (let ((extra (and header (shimbun-header-extra header))))
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)))
86 (if (setq extra (assoc field-name extras))
88 (shimbun-header-set-extra
90 (cons (cons field-name value) extras)))))
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))
101 (luna-define-class elmo-shimbun-folder
102 (elmo-map-folder) (shimbun headers header-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))
112 (setq hash (elmo-make-hash (length overviews)))
113 (dolist (entity overviews)
114 (elmo-set-hash-val (elmo-message-entity-field entity 'message-id)
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)
127 (setq header (elmo-shimbun-entity-to-header entity))
129 (elmo-shimbun-folder-set-header-hash-internal
131 (setq hash (elmo-make-hash))))
132 (elmo-set-hash-val (elmo-message-entity-field entity
138 (defsubst elmo-shimbun-lapse-seconds (time)
139 (let ((now (current-time)))
140 (+ (* (- (car now) (car time)) 65536)
141 (- (nth 1 now) (nth 1 time)))))
143 (defun elmo-shimbun-parse-time-string (string)
144 "Parse the time-string STRING and return its time as Emacs style."
146 (let ((x (timezone-fix-time string nil nil)))
147 (encode-time (aref x 5) (aref x 4) (aref x 3)
148 (aref x 2) (aref x 1) (aref x 0)
151 (defsubst elmo-shimbun-headers-check-p (folder)
152 (or (null (elmo-shimbun-folder-last-check-internal folder))
153 (and (elmo-shimbun-folder-last-check-internal folder)
154 (> (elmo-shimbun-lapse-seconds
155 (elmo-shimbun-folder-last-check-internal folder))
156 elmo-shimbun-check-interval))))
158 (defun elmo-shimbun-entity-to-header (entity)
159 (let (message-id shimbun-id)
160 (if (setq message-id (elmo-message-entity-field
161 entity 'x-original-id))
162 (setq shimbun-id (elmo-message-entity-field entity 'message-id))
163 (setq message-id (elmo-message-entity-field entity 'message-id)
165 (elmo-with-enable-multibyte
167 (elmo-message-entity-number entity)
168 (shimbun-mime-encode-string
169 (elmo-message-entity-field entity 'subject 'decode))
170 (shimbun-mime-encode-string
171 (elmo-message-entity-field entity 'from 'decode))
172 (elmo-message-entity-field entity 'date)
174 (elmo-message-entity-field entity 'references)
177 (elmo-message-entity-field entity 'xref)
179 (list (cons "x-shimbun-id" shimbun-id)))))))
181 (defsubst elmo-shimbun-folder-header-hash-setup (folder headers)
182 (let ((hash (or (elmo-shimbun-folder-header-hash-internal folder)
183 (elmo-make-hash (length headers)))))
184 (dolist (header headers)
185 (elmo-set-hash-val (shimbun-header-id header) header hash))
186 (elmo-shimbun-folder-set-header-hash-internal folder hash)))
188 (defun elmo-shimbun-get-headers (folder)
189 (let* ((shimbun (elmo-shimbun-folder-shimbun-internal folder))
190 (key (concat (shimbun-server shimbun)
191 "." (shimbun-current-group shimbun)))
192 (elmo-hash-minimum-size 63)
199 (unless (elmo-message-entity folder (shimbun-header-id x))
201 ;; This takes much time.
203 (elmo-shimbun-folder-shimbun-internal folder)
204 (elmo-shimbun-folder-range-internal folder)))))
205 (elmo-shimbun-folder-set-headers-internal folder headers)
207 (elmo-shimbun-folder-header-hash-setup folder headers))
208 (elmo-shimbun-folder-set-last-check-internal folder (current-time))))
210 (luna-define-method elmo-folder-initialize ((folder
213 (if (string= name "")
215 (let ((server-group (if (string-match "\\([^.]+\\)\\." name)
216 (list (elmo-match-string 1 name)
217 (substring name (match-end 0)))
219 (when (nth 0 server-group) ; server
220 (elmo-shimbun-folder-set-shimbun-internal
223 (shimbun-open (nth 0 server-group)
224 (luna-make-entity 'shimbun-elmo-mua :folder folder))
226 (luna-make-entity 'shimbun :server (nth 0 server-group))))))
227 (when (nth 1 server-group)
228 (elmo-shimbun-folder-set-group-internal
230 (nth 1 server-group)))
231 (elmo-shimbun-folder-set-range-internal
233 (or (cdr (elmo-string-matched-assoc (elmo-folder-name-internal folder)
234 elmo-shimbun-index-range-alist))
235 elmo-shimbun-default-index-range))
238 (luna-define-method elmo-folder-open-internal ((folder elmo-shimbun-folder))
239 (when (elmo-shimbun-folder-shimbun-internal folder)
241 (elmo-shimbun-folder-shimbun-internal folder)
242 (elmo-shimbun-folder-group-internal folder))
243 (let ((inhibit-quit t))
244 (unless (elmo-map-folder-location-alist-internal folder)
245 (elmo-map-folder-location-setup
247 (elmo-msgdb-location-load (elmo-folder-msgdb-path folder))))
248 (when (and (elmo-folder-plugged-p folder)
249 (elmo-shimbun-headers-check-p folder))
250 (elmo-shimbun-get-headers folder)
251 (elmo-map-folder-update-locations
253 (elmo-map-folder-list-message-locations folder))))))
255 (luna-define-method elmo-folder-reserve-status-p ((folder elmo-shimbun-folder))
258 (luna-define-method elmo-folder-local-p ((folder elmo-shimbun-folder))
261 (luna-define-method elmo-message-use-cache-p ((folder elmo-shimbun-folder)
263 elmo-shimbun-use-cache)
265 (luna-define-method elmo-folder-close-internal :after ((folder
266 elmo-shimbun-folder))
268 (elmo-shimbun-folder-shimbun-internal folder))
269 (elmo-shimbun-folder-set-headers-internal
271 (elmo-shimbun-folder-set-header-hash-internal
273 (elmo-shimbun-folder-set-entity-hash-internal
275 (elmo-shimbun-folder-set-last-check-internal
278 (luna-define-method elmo-folder-plugged-p ((folder elmo-shimbun-folder))
279 (if (elmo-shimbun-folder-shimbun-internal folder)
282 (shimbun-server (elmo-shimbun-folder-shimbun-internal folder))
284 (shimbun-server (elmo-shimbun-folder-shimbun-internal folder)))
287 (luna-define-method elmo-folder-set-plugged ((folder elmo-shimbun-folder)
288 plugged &optional add)
289 (elmo-set-plugged plugged
292 (elmo-shimbun-folder-shimbun-internal folder))
295 (elmo-shimbun-folder-shimbun-internal folder))
298 (luna-define-method elmo-net-port-info ((folder elmo-shimbun-folder))
301 (elmo-shimbun-folder-shimbun-internal folder))
304 (luna-define-method elmo-folder-check :around ((folder elmo-shimbun-folder))
305 (when (shimbun-current-group
306 (elmo-shimbun-folder-shimbun-internal folder))
307 (when (and (elmo-folder-plugged-p folder)
308 (elmo-shimbun-headers-check-p folder))
309 (elmo-shimbun-get-headers folder)
310 (luna-call-next-method))))
312 (luna-define-method elmo-folder-clear :around ((folder elmo-shimbun-folder)
313 &optional keep-killed)
314 (elmo-shimbun-folder-set-headers-internal folder nil)
315 (elmo-shimbun-folder-set-header-hash-internal folder nil)
316 (elmo-shimbun-folder-set-entity-hash-internal folder nil)
317 (elmo-shimbun-folder-set-last-check-internal folder nil)
318 (luna-call-next-method))
320 (luna-define-method elmo-folder-expand-msgdb-path ((folder
321 elmo-shimbun-folder))
323 (concat (shimbun-server
324 (elmo-shimbun-folder-shimbun-internal folder))
326 (elmo-shimbun-folder-group-internal folder))
327 (expand-file-name "shimbun" elmo-msgdb-directory)))
329 (defun elmo-shimbun-msgdb-create-entity (folder number)
330 (let ((header (elmo-shimbun-folder-shimbun-header
332 (elmo-map-message-location folder number)))
336 (shimbun-header-insert
337 (elmo-shimbun-folder-shimbun-internal folder)
339 (setq ov (elmo-msgdb-create-message-entity-from-buffer
340 (elmo-msgdb-message-entity-handler
341 (elmo-folder-msgdb-internal folder)) number))
342 (elmo-message-entity-set-field
344 'xref (shimbun-header-xref header)))
347 (luna-define-method elmo-folder-msgdb-create ((folder elmo-shimbun-folder)
349 (let ((new-msgdb (elmo-make-msgdb))
350 entity i percent length msgid flags)
351 (setq length (length numlist))
353 (message "Creating msgdb...")
356 (elmo-shimbun-msgdb-create-entity
357 folder (car numlist)))
359 (setq msgid (elmo-message-entity-field entity 'message-id)
360 flags (elmo-flag-table-get flag-table msgid))
361 (elmo-global-flags-set flags folder (car numlist) msgid)
362 (elmo-msgdb-append-entity new-msgdb entity flags))
363 (when (> length elmo-display-progress-threshold)
365 (setq percent (/ (* i 100) length))
366 (elmo-display-progress
367 'elmo-folder-msgdb-create "Creating msgdb..."
369 (setq numlist (cdr numlist)))
370 (message "Creating msgdb...done")
371 (elmo-msgdb-sort-by-date new-msgdb)))
373 (luna-define-method elmo-folder-message-file-p ((folder elmo-shimbun-folder))
376 (defsubst elmo-shimbun-update-overview (folder shimbun-id header)
377 (let ((entity (elmo-message-entity folder shimbun-id))
378 (message-id (shimbun-header-id header))
380 (when (elmo-msgdb-update-entity
381 (elmo-folder-msgdb folder)
384 (unless (string= shimbun-id message-id)
385 (elmo-shimbun-header-set-extra-field
386 header "x-shimbun-id" shimbun-id)
387 (elmo-set-hash-val message-id
389 (elmo-shimbun-folder-entity-hash folder))
390 (elmo-set-hash-val shimbun-id
392 (elmo-shimbun-folder-entity-hash folder))
393 (list (cons 'x-original-id message-id)))
396 (elmo-mime-string (shimbun-header-from header)))
398 (elmo-mime-string (shimbun-header-subject header)))
400 (shimbun-header-date header))
402 (or (elmo-msgdb-get-last-message-id
403 (elmo-field-body "in-reply-to"))
404 (elmo-msgdb-get-last-message-id
405 (elmo-field-body "references")))))))
406 (elmo-emit-signal 'update-overview folder
407 (elmo-message-entity-number entity)))))
409 (luna-define-method elmo-map-message-fetch ((folder elmo-shimbun-folder)
411 &optional section unseen)
412 (if (elmo-folder-plugged-p folder)
413 (let ((header (elmo-shimbun-folder-shimbun-header
417 (shimbun-article (elmo-shimbun-folder-shimbun-internal folder)
419 (when (or (eq elmo-shimbun-update-overview-folder-list 'all)
420 (elmo-string-match-member
421 (elmo-folder-name-internal folder)
422 elmo-shimbun-update-overview-folder-list))
423 (elmo-shimbun-update-overview folder location header))
424 (when (setq shimbun-id
425 (elmo-shimbun-header-extra-field header "x-shimbun-id"))
426 (goto-char (point-min))
427 (insert (format "X-Shimbun-Id: %s\n" shimbun-id)))
429 (error "Unplugged")))
431 (luna-define-method elmo-message-encache :around ((folder
433 number &optional read)
434 (if (elmo-folder-plugged-p folder)
435 (luna-call-next-method)
436 (if elmo-enable-disconnected-operation
437 (elmo-message-encache-dop folder number read)
438 (error "Unplugged"))))
440 (luna-define-method elmo-folder-list-messages-internal :around
441 ((folder elmo-shimbun-folder) &optional nohide)
442 (if (elmo-folder-plugged-p folder)
443 (luna-call-next-method)
446 (luna-define-method elmo-map-folder-list-message-locations
447 ((folder elmo-shimbun-folder))
448 (let ((expire-days (shimbun-article-expiration-days
449 (elmo-shimbun-folder-shimbun-internal folder))))
455 (when (and (elmo-message-entity-field ov 'xref)
457 (< (elmo-shimbun-lapse-seconds
458 (elmo-shimbun-parse-time-string
459 (elmo-message-entity-field ov 'date)))
460 (* expire-days 86400 ; seconds per day
463 (elmo-message-entity-field ov 'message-id)))
464 (elmo-folder-list-message-entities folder)))
467 (or (elmo-shimbun-header-extra-field header "x-shimbun-id")
468 (shimbun-header-id header)))
469 (elmo-shimbun-folder-headers-internal folder))))))
471 (luna-define-method elmo-folder-list-subfolders ((folder elmo-shimbun-folder)
473 (let ((prefix (elmo-folder-prefix-internal folder)))
474 (cond ((elmo-shimbun-folder-shimbun-internal folder)
475 (unless (elmo-shimbun-folder-group-internal folder)
480 (elmo-shimbun-folder-shimbun-internal folder))
482 (shimbun-groups (elmo-shimbun-folder-shimbun-internal folder)))))
483 ;; the rest are for "@/" group
486 (lambda (server) (list (concat prefix server)))
487 (shimbun-servers-list)))
490 (dolist (server (shimbun-servers-list))
494 (lambda (fld) (concat prefix server "." fld))
499 (concat prefix server))))
505 (luna-define-method elmo-folder-exists-p ((folder elmo-shimbun-folder))
506 (if (elmo-shimbun-folder-group-internal folder)
507 (if (fboundp 'shimbun-group-p)
508 (shimbun-group-p (elmo-shimbun-folder-shimbun-internal folder)
509 (elmo-shimbun-folder-group-internal folder))
511 (elmo-shimbun-folder-group-internal folder)
512 (shimbun-groups (elmo-shimbun-folder-shimbun-internal folder))))
515 (luna-define-method elmo-folder-delete-messages ((folder elmo-shimbun-folder)
517 (elmo-folder-kill-messages folder numbers)
520 (luna-define-method elmo-message-entity-parent ((folder elmo-shimbun-folder)
522 (let ((references (elmo-message-entity-field entity 'references)))
524 (elmo-get-hash-val references
525 (elmo-shimbun-folder-entity-hash folder)))))
528 (product-provide (provide 'elmo-shimbun) (require 'elmo-version))
530 ;;; elmo-shimbun.el ends here