1 ;;; modb-standard.el --- Standartd Implement of MODB.
3 ;; Copyright (C) 2003 Yuuichi Teranishi <teranisi@gohome.org>
5 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
6 ;; Hiroya Murata <lapis-lazuli@pop06.odn.ne.jp>
7 ;; Keywords: mail, net news
9 ;; This file is part of ELMO (Elisp Library for Message Orchestration).
11 ;; This program is free software; you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation; either version 2, or (at your option)
16 ;; This program is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs; see the file COPYING. If not, write to the
23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
24 ;; Boston, MA 02111-1307, USA.
32 (eval-when-compile (require 'cl
))
37 (defcustom modb-standard-divide-number
500
38 "*Standard modb divide entity number."
39 :type
'(choice (const :tag
"Not divide" nil
)
43 (defvar modb-standard-entity-filename
"entity"
44 "Message entity database.")
46 (defvar modb-standard-flag-filename
"flag"
47 "Message number <=> Flag status database.")
49 (defvar modb-standard-msgid-filename
"msgid"
50 "Message number <=> Message-Id database.")
53 (luna-define-class modb-standard
(modb-generic)
54 (number-list ; sorted list of message numbers.
55 entity-map
; number, msg-id -> entity mapping.
56 flag-map
; number -> flag-list mapping
57 flag-count
; list of (FLAG . COUNT)
58 overview-handler
; instance of modb-entity-handler.
60 (luna-define-internal-accessors 'modb-standard
))
62 ;; for internal use only
63 (defsubst modb-standard-key
(number)
64 (concat "#" (number-to-string number
)))
66 (defsubst modb-standard-entity-id
(entity)
67 (if (eq 'autoload
(car-safe entity
))
69 (elmo-msgdb-message-entity-field
70 (elmo-message-entity-handler entity
)
73 (defsubst modb-standard-entity-map
(modb)
74 (or (modb-standard-entity-map-internal modb
)
75 (modb-standard-set-entity-map-internal
77 (elmo-make-hash (elmo-msgdb-length modb
)))))
79 (defsubst modb-standard-flag-map
(modb)
80 (or (modb-standard-flag-map-internal modb
)
81 (modb-standard-set-flag-map-internal
83 (elmo-make-hash (elmo-msgdb-length modb
)))))
85 (defsubst modb-standard-set-message-modified
(modb number
)
86 (if modb-standard-divide-number
87 (let ((section (/ number modb-standard-divide-number
))
88 (modified (modb-generic-message-modified-internal modb
)))
89 (unless (memq section modified
)
90 (modb-generic-set-message-modified-internal
91 modb
(cons section modified
))))
92 (modb-generic-set-message-modified-internal modb t
)))
94 (defsubst modb-standard-set-flag-modified
(modb number
)
95 (modb-generic-set-flag-modified-internal modb t
))
97 (defsubst modb-standard-message-flags
(modb number
)
98 (cdr (elmo-get-hash-val (modb-standard-key number
)
99 (modb-standard-flag-map-internal modb
))))
101 (defsubst modb-standard-match-flags
(check-flags flags
)
104 (when (memq (car check-flags
) flags
)
106 (setq check-flags
(cdr check-flags
)))))
108 (defsubst modb-standard-countup-flags
(modb flags
&optional delta
)
109 (let ((flag-count (modb-standard-flag-count-internal modb
))
113 (if (setq elem
(assq flag flag-count
))
114 (setcdr elem
(+ (cdr elem
) delta
))
115 (setq flag-count
(cons (cons flag delta
) flag-count
))))
116 (modb-standard-set-flag-count-internal modb flag-count
)))
118 ;; save and load functions
119 (defun modb-standard-load-msgid (modb path
)
120 (let* ((alist (elmo-object-load
121 (expand-file-name modb-standard-msgid-filename path
)))
122 (table (or (modb-standard-entity-map-internal modb
)
123 (elmo-make-hash (length alist
))))
126 (setq info
(cons 'autoload pair
))
127 (elmo-set-hash-val (modb-standard-key (car pair
)) info table
)
128 (elmo-set-hash-val (cdr pair
) info table
)
129 (setq numbers
(cons (car pair
) numbers
)))
130 (modb-standard-set-number-list-internal modb
(nreverse numbers
))
131 (modb-standard-set-entity-map-internal modb table
)))
133 (defun modb-standard-save-msgid (modb path
)
134 (let ((table (modb-standard-entity-map-internal modb
))
136 (dolist (number (modb-standard-number-list-internal modb
))
137 (setq entity
(elmo-get-hash-val (modb-standard-key number
) table
))
138 (setq alist
(cons (cons number
(modb-standard-entity-id entity
))
141 (expand-file-name modb-standard-msgid-filename path
)
144 (defun modb-standard-load-flag (modb path
)
145 (let ((table (or (modb-standard-flag-map-internal modb
)
146 (elmo-make-hash (elmo-msgdb-length modb
)))))
147 (dolist (info (elmo-object-load
148 (expand-file-name modb-standard-flag-filename path
)))
149 (modb-standard-countup-flags modb
(cdr info
))
150 (elmo-set-hash-val (modb-standard-key (car info
)) info table
))
151 (modb-standard-set-flag-map-internal modb table
)))
153 (defun modb-standard-save-flag (modb path
)
154 (let (table flist info
)
155 (when (setq table
(modb-standard-flag-map-internal modb
))
158 (setq info
(symbol-value atom
))
160 (setq flist
(cons info flist
))))
163 (expand-file-name modb-standard-flag-filename path
)
166 (defsubst modb-standard-entity-filename
(section)
168 (concat modb-standard-entity-filename
170 (number-to-string section
))
171 modb-standard-entity-filename
))
173 (defsubst modb-standard-loaded-message-id
(msgdb number
)
174 "Get message-id for autoloaded entity."
175 (let ((ret (elmo-get-hash-val
176 (modb-standard-key number
)
177 (modb-standard-entity-map-internal msgdb
))))
181 (elmo-clear-hash-val (modb-standard-key number
)
182 (modb-standard-entity-map-internal msgdb
))
184 ((eq (car-safe ret
) 'autoload
)
185 (cdr (cdr ret
))) ; message-id.
186 ((elmo-msgdb-message-entity-field (elmo-message-entity-handler ret
)
187 ret
'message-id
)) ; Already loaded.
188 (t (error "Internal error: invalid msgdb status")))))
190 (defun modb-standard-load-entity (modb path
&optional section
)
191 (let ((table (or (modb-standard-entity-map-internal modb
)
192 (elmo-make-hash (elmo-msgdb-length modb
))))
193 (objects (elmo-object-load
195 (modb-standard-entity-filename section
)
198 (cond ((eq (car objects
) 'modb-standard-entity-handler
)
199 ;; (standard PARAMETERS ENTITY*)
200 (let ((handler (apply #'luna-make-entity
202 (car (cdr objects
))))
204 (dolist (element (cdr (cdr objects
)))
205 (setq entity
(cons handler
(cons nil element
))
206 number
(elmo-msgdb-message-entity-number handler entity
)
207 msgid
(modb-standard-loaded-message-id modb number
))
209 (elmo-msgdb-message-entity-set-field
210 handler entity
'message-id msgid
)
211 (elmo-set-hash-val (modb-standard-key number
) entity table
)
212 (elmo-set-hash-val msgid entity table
)))))
215 (dolist (entity objects
)
216 (setq number
(elmo-msgdb-message-entity-number
217 (elmo-message-entity-handler entity
)
219 msgid
(modb-standard-loaded-message-id modb number
))
221 (setcar entity msgid
)
222 (elmo-set-hash-val (modb-standard-key number
) entity table
)
223 (elmo-set-hash-val msgid entity table
)))))
224 (modb-standard-set-entity-map-internal modb table
)))
226 (defsubst modb-standard-save-entity-1
(modb path
&optional section
)
227 (let ((table (modb-standard-entity-map-internal modb
))
228 (filename (expand-file-name
229 (modb-standard-entity-filename (car section
)) path
))
230 (handler (elmo-msgdb-message-entity-handler modb
))
232 (dolist (number (or (cdr section
)
233 (modb-standard-number-list-internal modb
)))
234 (when (setq entity
(elmo-msgdb-message-entity modb number
))
235 (unless (modb-entity-handler-equal-p
237 (elmo-message-entity-handler entity
))
238 (setq entity
(elmo-msgdb-copy-message-entity
239 (elmo-message-entity-handler entity
)
241 (setq entities
(cons (cdr (cdr entity
)) entities
))))
243 (elmo-object-save filename
245 (list (luna-class-name handler
)
246 (modb-entity-handler-dump-parameters handler
))
248 (ignore-errors (delete-file filename
)))))
250 (defun modb-standard-cleanup-stale-entities (modb path
)
251 (message "Removing stale entities...")
253 (concat "^" modb-standard-entity-filename
"-\\([0-9]+\\)"))
254 (entities (elmo-uniq-list
256 #'(lambda (x) (/ x modb-standard-divide-number
))
257 (modb-standard-number-list-internal modb
))))
258 (files (mapcar #'(lambda(x)
259 (when (string-match entity-regex x
)
260 (string-to-int (match-string 1 x
))))
261 (directory-files path nil entity-regex
))))
262 (dolist (entity (car (elmo-list-diff-nonsortable files entities
)))
263 (ignore-errors (delete-file
265 (modb-standard-entity-filename entity
) path
))))))
267 (defun modb-standard-save-entity (modb path
)
268 (let ((modified (modb-generic-message-modified-internal modb
)))
269 (cond ((listp modified
)
270 (let ((sections (mapcar 'list modified
))
272 (dolist (number (modb-standard-number-list-internal modb
))
273 (when (setq section
(assq (/ number modb-standard-divide-number
)
275 (nconc section
(list number
))))
276 (dolist (section sections
)
277 (modb-standard-save-entity-1 modb path section
))))
279 (modb-standard-save-entity-1 modb path
))))
280 (modb-standard-cleanup-stale-entities modb path
))
284 (luna-define-method elmo-msgdb-load
((msgdb modb-standard
))
285 (let ((inhibit-quit t
)
286 (path (elmo-msgdb-location msgdb
)))
287 (when (file-exists-p (expand-file-name modb-standard-flag-filename path
))
288 (modb-standard-load-msgid msgdb path
)
289 (modb-standard-load-flag msgdb path
)
290 (unless modb-standard-divide-number
291 (modb-standard-load-entity msgdb path
))
294 (luna-define-method elmo-msgdb-save
((msgdb modb-standard
))
295 (let ((path (elmo-msgdb-location msgdb
))
297 (when (elmo-msgdb-message-modified-p msgdb
)
298 (modb-standard-save-msgid msgdb path
)
299 (modb-standard-save-entity msgdb path
)
300 (modb-generic-set-message-modified-internal msgdb nil
))
301 (when (elmo-msgdb-flag-modified-p msgdb
)
302 (modb-standard-save-flag msgdb path
)
303 (modb-generic-set-flag-modified-internal msgdb nil
))))
305 (luna-define-method elmo-msgdb-append
:around
((msgdb modb-standard
)
307 (when (> (elmo-msgdb-length msgdb-append
) 0)
308 (if (eq (luna-class-name msgdb-append
) 'modb-standard
)
309 (let ((numbers (modb-standard-number-list-internal msgdb-append
))
312 (modb-standard-set-number-list-internal
314 (nconc (modb-standard-number-list-internal msgdb
)
317 (let ((table (modb-standard-entity-map msgdb
))
319 (dolist (number numbers
)
320 (setq entity
(elmo-msgdb-message-entity msgdb-append number
)
321 msg-id
(modb-standard-entity-id entity
))
322 (if (elmo-get-hash-val msg-id table
)
323 (setq duplicates
(cons number duplicates
))
324 (elmo-set-hash-val msg-id entity table
))
325 (elmo-set-hash-val (modb-standard-key number
)
329 (let ((table (modb-standard-flag-map msgdb
)))
332 (elmo-set-hash-val (symbol-name atom
)
335 (modb-standard-flag-map msgdb-append
)))
337 (dolist (pair (modb-standard-flag-count-internal msgdb-append
))
338 (modb-standard-countup-flags msgdb
(list (car pair
)) (cdr pair
)))
339 ;; modification flags
340 (dolist (number (modb-standard-number-list-internal msgdb-append
))
341 (modb-standard-set-message-modified msgdb number
)
342 (modb-standard-set-flag-modified msgdb number
))
344 (luna-call-next-method))))
346 (luna-define-method elmo-msgdb-clear
:after
((msgdb modb-standard
))
347 (modb-standard-set-number-list-internal msgdb nil
)
348 (modb-standard-set-entity-map-internal msgdb nil
)
349 (modb-standard-set-flag-map-internal msgdb nil
)
350 (modb-standard-set-flag-count-internal msgdb nil
))
352 (luna-define-method elmo-msgdb-length
((msgdb modb-standard
))
353 (length (modb-standard-number-list-internal msgdb
)))
355 (luna-define-method elmo-msgdb-flag-available-p
((msgdb modb-standard
) flag
)
358 (luna-define-method elmo-msgdb-flags
((msgdb modb-standard
) number
)
359 (modb-standard-message-flags msgdb number
))
361 (luna-define-method elmo-msgdb-set-flag
((msgdb modb-standard
)
365 (elmo-msgdb-unset-flag msgdb number
'unread
))
367 (elmo-msgdb-unset-flag msgdb number
'cached
))
369 (let ((cur-flags (modb-standard-message-flags msgdb number
))
371 (unless (memq flag cur-flags
)
372 (setq new-flags
(cons flag cur-flags
))
373 (setq diff
(elmo-list-diff-nonsortable new-flags cur-flags
))
374 (modb-standard-countup-flags msgdb
(car diff
))
375 (modb-standard-countup-flags msgdb
(cadr diff
) -
1)
376 (elmo-set-hash-val (modb-standard-key number
)
377 (cons number new-flags
)
378 (modb-standard-flag-map msgdb
))
379 (modb-standard-set-flag-modified msgdb number
))))))
381 (luna-define-method elmo-msgdb-unset-flag
((msgdb modb-standard
)
385 (elmo-msgdb-set-flag msgdb number
'unread
))
387 (elmo-msgdb-set-flag msgdb number
'cached
))
389 (modb-standard-countup-flags msgdb
390 (modb-standard-message-flags msgdb number
)
392 (elmo-clear-hash-val (modb-standard-key number
)
393 (modb-standard-flag-map msgdb
)))
395 (let ((cur-flags (modb-standard-message-flags msgdb number
))
398 (when (memq flag cur-flags
)
399 (setq new-flags
(delq flag
(copy-sequence cur-flags
)))
400 (setq diff
(elmo-list-diff-nonsortable new-flags cur-flags
))
401 (modb-standard-countup-flags msgdb
(car diff
))
402 (modb-standard-countup-flags msgdb
(cadr diff
) -
1)
403 (elmo-set-hash-val (modb-standard-key number
)
404 (cons number new-flags
)
405 (modb-standard-flag-map msgdb
))
406 (modb-standard-set-flag-modified msgdb number
))
407 (when (eq flag
'unread
)
408 (elmo-msgdb-unset-flag msgdb number
'new
))))))
410 (luna-define-method elmo-msgdb-flag-count
((msgdb modb-standard
))
411 (modb-standard-flag-count-internal msgdb
))
413 (luna-define-method elmo-msgdb-list-messages
((msgdb modb-standard
))
415 (modb-standard-number-list-internal msgdb
)))
417 (luna-define-method elmo-msgdb-list-flagged
((msgdb modb-standard
) flag
)
421 (dolist (number (modb-standard-number-list-internal msgdb
))
422 (unless (memq 'unread
(modb-standard-message-flags msgdb number
))
423 (setq matched
(cons number matched
)))))
425 (dolist (number (modb-standard-number-list-internal msgdb
))
426 (unless (memq 'cached
(modb-standard-message-flags msgdb number
))
427 (setq matched
(cons number matched
)))))
431 (setq entry
(symbol-value atom
))
432 (unless (and (eq (length (cdr entry
)) 1)
433 (eq (car (cdr entry
)) 'cached
))
434 ;; If there is a flag other than cached, then the message
436 (setq matched
(cons (car entry
) matched
))))
437 (modb-standard-flag-map msgdb
)))
439 (let ((flags (append elmo-digest-flags
440 (elmo-get-global-flags t t
))))
443 (setq entry
(symbol-value atom
))
444 (when (modb-standard-match-flags flags
(cdr entry
))
445 (setq matched
(cons (car entry
) matched
))))
446 (modb-standard-flag-map msgdb
))))
450 (setq entry
(symbol-value atom
))
451 (when (memq flag
(cdr entry
))
452 (setq matched
(cons (car entry
) matched
))))
453 (modb-standard-flag-map msgdb
))))
456 (luna-define-method elmo-msgdb-search
((msgdb modb-standard
)
457 condition
&optional numbers
)
458 (if (vectorp condition
)
459 (let ((key (elmo-filter-key condition
))
462 ((and (string= key
"flag")
463 (eq (elmo-filter-type condition
) 'match
))
464 (setq results
(elmo-msgdb-list-flagged
466 (intern (elmo-filter-value condition
))))
468 (elmo-list-filter numbers results
)
470 ((member key
'("first" "last"))
471 (let* ((numbers (or numbers
472 (modb-standard-number-list-internal msgdb
)))
473 (len (length numbers
))
474 (lastp (string= key
"last"))
475 (value (string-to-number (elmo-filter-value condition
))))
476 (when (eq (elmo-filter-type condition
) 'unmatch
)
477 (setq lastp
(not lastp
)
478 value
(- len value
)))
480 (nthcdr (max (- len value
) 0) numbers
)
482 (let* ((numbers (copy-sequence numbers
))
483 (last (nthcdr (1- value
) numbers
)))
491 (luna-define-method elmo-msgdb-append-entity
((msgdb modb-standard
)
492 entity
&optional flags
)
494 (let ((number (elmo-msgdb-message-entity-number
495 (elmo-message-entity-handler entity
) entity
))
496 (msg-id (elmo-msgdb-message-entity-field
497 (elmo-message-entity-handler entity
) entity
'message-id
))
499 (when (and number msg-id
)
501 (modb-standard-set-number-list-internal
503 (nconc (modb-standard-number-list-internal msgdb
)
506 (let ((table (modb-standard-entity-map msgdb
)))
507 (setq duplicate
(elmo-get-hash-val msg-id table
))
508 (elmo-set-hash-val (modb-standard-key number
) entity table
)
509 (elmo-set-hash-val msg-id entity table
))
510 ;; modification flags
511 (modb-standard-set-message-modified msgdb number
)
515 (modb-standard-key number
)
517 (modb-standard-flag-map msgdb
))
518 (modb-standard-countup-flags msgdb flags
)
519 (modb-standard-set-flag-modified msgdb number
))
522 (luna-define-method elmo-msgdb-update-entity
((msgdb modb-standard
)
524 (let ((handler (elmo-message-entity-handler entity
)))
525 (when (elmo-msgdb-message-entity-update-fields handler entity values
)
526 (modb-standard-set-message-modified
528 (elmo-msgdb-message-entity-number handler entity
))
531 (luna-define-method elmo-msgdb-delete-messages
((msgdb modb-standard
)
533 (let ((number-list (modb-standard-number-list-internal msgdb
))
534 (entity-map (modb-standard-entity-map-internal msgdb
))
535 (flag-map (modb-standard-flag-map-internal msgdb
))
537 (dolist (number numbers
)
538 (setq key
(modb-standard-key number
)
539 entity
(elmo-get-hash-val key entity-map
))
542 (setq number-list
(delq number number-list
))
544 (elmo-clear-hash-val key entity-map
)
545 (elmo-clear-hash-val (modb-standard-entity-id entity
) entity-map
)
546 ;; flag-count (must be BEFORE flag-map)
547 (modb-standard-countup-flags
549 (modb-standard-message-flags msgdb number
)
552 (elmo-clear-hash-val key flag-map
)
553 (modb-standard-set-message-modified msgdb number
)
554 (modb-standard-set-flag-modified msgdb number
)))
555 (modb-standard-set-number-list-internal msgdb number-list
)
556 (modb-standard-set-entity-map-internal msgdb entity-map
)
557 (modb-standard-set-flag-map-internal msgdb flag-map
)
560 (luna-define-method elmo-msgdb-sort-entities
((msgdb modb-standard
)
561 predicate
&optional app-data
)
562 (message "Sorting...")
563 (let ((numbers (modb-standard-number-list-internal msgdb
)))
564 (modb-standard-set-number-list-internal
566 (sort numbers
(lambda (a b
)
568 (elmo-msgdb-message-entity msgdb a
)
569 (elmo-msgdb-message-entity msgdb b
)
571 (message "Sorting...done")
574 (defun modb-standard-message-entity (msgdb key load
)
575 (let ((ret (elmo-get-hash-val
577 (modb-standard-entity-map-internal msgdb
)))
579 (if (eq 'autoload
(car-safe ret
))
580 (when (and load modb-standard-divide-number
)
581 (modb-standard-load-entity
583 (elmo-msgdb-location msgdb
)
584 (/ (nth 1 ret
) modb-standard-divide-number
))
585 (modb-standard-message-entity msgdb key nil
))
588 (luna-define-method elmo-msgdb-message-number
((msgdb modb-standard
)
590 (let ((ret (elmo-get-hash-val
592 (modb-standard-entity-map-internal msgdb
))))
593 (if (eq 'autoload
(car-safe ret
))
594 ;; Not loaded yet but can return number.
596 (elmo-message-entity-number ret
))))
598 (luna-define-method elmo-msgdb-message-field
((msgdb modb-standard
)
599 number field
&optional type
)
600 (let ((ret (elmo-get-hash-val
601 (modb-standard-key number
)
602 (modb-standard-entity-map-internal msgdb
))))
603 (if (and (eq 'autoload
(car-safe ret
)) (eq field
'message-id
))
604 ;; Not loaded yet but can return message-id
606 (elmo-message-entity-field (elmo-msgdb-message-entity
607 msgdb
(modb-standard-key number
))
610 (luna-define-method elmo-msgdb-message-entity
((msgdb modb-standard
) key
)
612 (modb-standard-message-entity
614 (cond ((stringp key
) key
)
615 ((numberp key
) (modb-standard-key key
)))
618 (luna-define-method elmo-msgdb-message-entity-handler
((msgdb modb-standard
))
619 (or (modb-standard-overview-handler-internal msgdb
)
620 (modb-standard-set-overview-handler-internal
622 (luna-make-entity 'modb-standard-entity-handler
624 (modb-generic-mime-charset-internal msgdb
)))))
627 (product-provide (provide 'modb-standard
) (require 'elmo-version
))
629 ;;; modb-standard.el ends here