New feature: toggle visibility of mime buttons.
[more-wl.git] / elmo / modb-entity.el
blob77d53ce3aa50ab9466ce17c125979483f624ca31
1 ;;; modb-entity.el --- Message Entity Interface.
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)
14 ;; any later version.
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.
27 ;;; Commentary:
29 ;; Message entity handling.
31 ;;; Code:
33 (eval-when-compile (require 'cl))
35 (require 'luna)
36 (require 'elmo-vars)
37 (require 'elmo-util)
39 (eval-and-compile
40 (luna-define-class modb-entity-handler () (mime-charset))
41 (luna-define-internal-accessors 'modb-entity-handler))
43 (defcustom modb-entity-default-handler 'modb-legacy-entity-handler
44 "Default entity handler."
45 :type 'symbol
46 :group 'elmo)
48 (defcustom modb-entity-field-extractor-alist
49 '((ml-info modb-entity-extract-mailing-list-info
50 modb-entity-ml-info-real-fields))
51 "*An alist of field name and function to extract field body from buffer."
52 :type '(repeat (list (symbol :tag "Field Name")
53 (function :tag "Extractor")
54 (choice :tag "Real Field"
55 (repeat :tag "Field Name List" string)
56 (function :tag "Function"))))
57 :group 'elmo)
59 (defvar modb-entity-default-cache-internal nil)
61 (defun elmo-message-entity-handler (&optional entity)
62 "Get modb entity handler instance which corresponds to the ENTITY."
63 (if (and entity
64 (car-safe entity)
65 (not (eq (car entity) t))
66 (not (stringp (car entity))))
67 (car entity)
68 (or modb-entity-default-cache-internal
69 (setq modb-entity-default-cache-internal
70 (luna-make-entity modb-entity-default-handler)))))
72 (luna-define-generic modb-entity-handler-list-parameters (handler)
73 "Return a parameter list of HANDLER.")
75 (luna-define-generic elmo-msgdb-make-message-entity (handler &rest args)
76 "Make a message entity using HANDLER.")
78 (luna-define-generic elmo-msgdb-message-entity-number (handler entity)
79 "Number of the ENTITY.")
81 (luna-define-generic elmo-msgdb-message-entity-set-number (handler
82 entity number)
83 "Set number of the ENTITY.")
85 (luna-define-generic elmo-msgdb-message-entity-field (handler entity field
86 &optional type)
87 "Retrieve field value of the message entity.
88 HANDLER is the message entity handler.
89 ENTITY is the message entity structure.
90 FIELD is a symbol of the field.
91 If optional argument TYPE is specified, return converted value.")
93 (luna-define-generic elmo-msgdb-message-entity-set-field (handler
94 entity field value)
95 "Set the field value of the message entity.
96 HANDLER is the message entity handler.
97 ENTITY is the message entity structure.
98 FIELD is a symbol of the field.
99 VALUE is the field value to set.")
101 (luna-define-generic elmo-msgdb-message-entity-update-fields (handler
102 entity values)
103 "Update message entity by VALUES.
104 HANDLER is the message entity handler.
105 ENTITY is the message entity structure.
106 VALUES is an alist of field-name and field-value.")
108 (luna-define-generic elmo-msgdb-copy-message-entity (handler entity
109 &optional
110 make-handler)
111 "Copy message entity.
112 HANDLER is the message entity handler.
113 ENTITY is the message entity structure.
114 If optional argument MAKE-HANDLER is specified, use it to make new entity.")
116 (luna-define-generic elmo-msgdb-create-message-entity-from-file (handler
117 number
118 file)
119 "Create message entity from file.
120 HANDLER is the message entity handler.
121 NUMBER is the number of the newly created message entity.
122 FILE is the message file.")
124 (luna-define-generic elmo-msgdb-create-message-entity-from-buffer (handler
125 number
126 &rest args)
127 "Create message entity from current buffer.
128 HANDLER is the message entity handler.
129 NUMBER is the number of the newly created message entity.
130 Rest of the ARGS is a plist of message entity field for initial value.
131 Header region is supposed to be narrowed.")
133 ;; Transitional interface.
134 (luna-define-generic elmo-msgdb-message-match-condition (handler
135 condition
136 entity)
137 "Return non-nil when the entity matches the condition.")
139 ;; Generic implementation.
140 (luna-define-method initialize-instance :after ((handler modb-entity-handler)
141 &rest init-args)
142 (unless (modb-entity-handler-mime-charset-internal handler)
143 (modb-entity-handler-set-mime-charset-internal handler elmo-mime-charset))
144 handler)
146 (luna-define-method modb-entity-handler-list-parameters
147 ((handler modb-entity-handler))
148 (list 'mime-charset))
150 (luna-define-method elmo-msgdb-create-message-entity-from-file
151 ((handler modb-entity-handler) number file)
152 (let (insert-file-contents-pre-hook ; To avoid autoconv-xmas...
153 insert-file-contents-post-hook header-end
154 (attrib (file-attributes file))
155 ret-val size mtime)
156 (with-temp-buffer
157 (if (not (file-exists-p file))
159 (setq size (nth 7 attrib))
160 (setq mtime (timezone-make-date-arpa-standard
161 (current-time-string (nth 5 attrib)) (current-time-zone)))
162 ;; insert header from file.
163 (catch 'done
164 (condition-case nil
165 (elmo-msgdb-insert-file-header file)
166 (error (throw 'done nil)))
167 (goto-char (point-min))
168 (setq header-end
169 (if (re-search-forward "\\(^--.*$\\)\\|\\(\n\n\\)" nil t)
170 (point)
171 (point-max)))
172 (narrow-to-region (point-min) header-end)
173 (elmo-msgdb-create-message-entity-from-buffer
174 handler number :size size :date mtime))))))
176 (luna-define-method elmo-msgdb-make-message-entity ((handler
177 modb-entity-handler)
178 args)
179 (cons handler args))
181 (luna-define-method elmo-msgdb-message-entity-field ((handler
182 modb-entity-handler)
183 entity field
184 &optional type)
185 (plist-get (cdr entity) (intern (concat ":" (symbol-name field)))))
187 (luna-define-method elmo-msgdb-message-entity-number ((handler
188 modb-entity-handler)
189 entity)
190 (plist-get (cdr entity) :number))
192 (luna-define-method elmo-msgdb-message-entity-update-fields
193 ((handler modb-entity-handler) entity values)
194 (let (updated)
195 (dolist (pair values)
196 (unless (equal
197 (cdr pair)
198 (elmo-msgdb-message-entity-field handler entity (car pair)))
199 (elmo-msgdb-message-entity-set-field handler entity
200 (car pair) (cdr pair))
201 (setq updated t)))
202 updated))
204 ;; helper functions
205 (defsubst modb-entity-handler-mime-charset (handler)
206 (or (modb-entity-handler-mime-charset-internal handler)
207 elmo-mime-charset))
209 (defun modb-entity-handler-equal-p (handler other)
210 "Return non-nil, if OTHER hanlder is equal this HANDLER."
211 (and (eq (luna-class-name handler)
212 (luna-class-name other))
213 (catch 'mismatch
214 (dolist (slot (modb-entity-handler-list-parameters handler))
215 (when (not (equal (luna-slot-value handler slot)
216 (luna-slot-value other slot)))
217 (throw 'mismatch nil)))
218 t)))
220 (defun modb-entity-handler-dump-parameters (handler)
221 "Return parameters for reconstruct HANDLER as plist."
222 (apply #'nconc
223 (mapcar (lambda (slot)
224 (let ((value (luna-slot-value handler slot)))
225 (when value
226 (list (intern (concat ":" (symbol-name slot)))
227 value))))
228 (modb-entity-handler-list-parameters handler))))
230 ;; field in/out converter
231 (defun modb-set-field-converter (converter type &rest specs)
232 "Set convert function of TYPE into CONVERTER.
233 SPECS must be like `FIELD1 FUNCTION1 FIELD2 FUNCTION2 ...'.
234 If each field is t, function is set as default converter."
235 (when specs
236 (let ((alist (symbol-value converter))
237 (type (or type t)))
238 (while specs
239 (let ((field (pop specs))
240 (function (pop specs))
241 cell)
242 (if (setq cell (assq type alist))
243 (setcdr cell (put-alist field function (cdr cell)))
244 (setq cell (cons type (list (cons field function)))
245 alist (cons cell alist)))
246 ;; support colon keyword (syntax sugar).
247 (unless (or (eq field t)
248 (string-match "^:" (symbol-name field)))
249 (setcdr cell (put-alist (intern (concat ":" (symbol-name field)))
250 function
251 (cdr cell))))))
252 (set converter alist))))
253 (put 'modb-set-field-converter 'lisp-indent-function 2)
255 (defsubst modb-convert-field-value (converter field value &optional type)
256 (and value
257 (let* ((alist (cdr (assq (or type t) converter)))
258 (function (cdr (or (assq field alist)
259 (assq t alist)))))
260 (if function
261 (funcall function field value)
262 value))))
264 ;; mime decode cache
265 (defvar elmo-msgdb-decoded-cache-hashtb nil)
266 (make-variable-buffer-local 'elmo-msgdb-decoded-cache-hashtb)
268 (defsubst elmo-msgdb-get-decoded-cache (string)
269 (if elmo-use-decoded-cache
270 (let ((hashtb (or elmo-msgdb-decoded-cache-hashtb
271 (setq elmo-msgdb-decoded-cache-hashtb
272 (elmo-make-hash 2048))))
273 decoded)
274 (or (elmo-get-hash-val string hashtb)
275 (prog1
276 (setq decoded
277 (elmo-with-enable-multibyte
278 (decode-mime-charset-string string elmo-mime-charset)))
279 (elmo-set-hash-val string decoded hashtb))))
280 (elmo-with-enable-multibyte
281 (decode-mime-charset-string string elmo-mime-charset))))
283 (defun modb-entity-string-decoder (field value)
284 (elmo-msgdb-get-decoded-cache value))
286 (defun modb-entity-string-encoder (field value)
287 (elmo-with-enable-multibyte
288 (encode-mime-charset-string value elmo-mime-charset)))
290 (defun modb-entity-parse-date-string (field value)
291 (if (stringp value)
292 (elmo-time-parse-date-string value)
293 value))
295 (defun modb-entity-make-date-string (field value)
296 (if (stringp value)
297 value
298 (elmo-time-make-date-string value)))
300 (defun modb-entity-mime-decoder (field value)
301 (mime-decode-field-body value (symbol-name field) 'summary))
303 (defun modb-entity-mime-encoder (field value)
304 (mime-encode-field-body value (symbol-name field)))
306 (defun modb-entity-address-list-decoder (field value)
307 (if (stringp value)
308 (mapcar (lambda (address)
309 (mime-decode-field-body address (symbol-name field)))
310 (elmo-parse-addresses value))
311 value))
313 (defun modb-entity-address-list-encoder (field value)
314 (if (stringp value)
315 value
316 (mime-encode-field-body (mapconcat 'identity value ", ")
317 (symbol-name field))))
319 (defun modb-entity-parse-address-string (field value)
320 (modb-entity-encode-string-recursive
321 field
322 (if (stringp value)
323 (elmo-parse-addresses value)
324 value)))
326 (defun modb-entity-make-address-string (field value)
327 (let ((value (modb-entity-decode-string-recursive field value)))
328 (if (stringp value)
329 value
330 (mapconcat 'identity value ", "))))
332 (defun modb-entity-decode-string-recursive (field value)
333 (elmo-map-recursive
334 (lambda (element)
335 (if (stringp element)
336 (elmo-msgdb-get-decoded-cache element)
337 element))
338 value))
340 (defun modb-entity-encode-string-recursive (field value)
341 (elmo-map-recursive
342 (lambda (element)
343 (if (stringp element)
344 (elmo-with-enable-multibyte
345 (encode-mime-charset-string element elmo-mime-charset))
346 element))
347 value))
349 (defun modb-entity-create-field-indices (slots)
350 (let ((index 0)
351 indices)
352 (while slots
353 (setq indices (cons (cons (car slots) index) indices)
354 index (1+ index)
355 slots (cdr slots)))
356 (append
357 indices
358 (mapcar (lambda (cell)
359 (cons (intern (concat ":" (symbol-name (car cell))))
360 (cdr cell)))
361 indices))))
364 ;; Legacy implementation.
365 (eval-and-compile
366 (luna-define-class modb-legacy-entity-handler (modb-entity-handler)))
368 (defconst modb-legacy-entity-field-slots
369 '(number
370 references
371 from
372 subject
373 date
376 size
377 extra))
379 (defconst modb-legacy-entity-field-indices
380 (modb-entity-create-field-indices modb-legacy-entity-field-slots))
382 (defvar modb-legacy-entity-normalizer nil)
383 (modb-set-field-converter 'modb-legacy-entity-normalizer nil
384 'message-id nil
385 'number nil
386 'references nil
387 'from #'modb-entity-string-encoder
388 'subject #'modb-entity-string-encoder
389 'date #'modb-entity-make-date-string
390 'to #'modb-entity-address-list-encoder
391 'cc #'modb-entity-address-list-encoder
392 'size nil
393 t #'modb-entity-mime-encoder)
395 (defvar modb-legacy-entity-specializer nil)
396 ;; default type
397 (modb-set-field-converter 'modb-legacy-entity-specializer nil
398 'message-id nil
399 'number nil
400 'references nil
401 'from #'modb-entity-string-decoder
402 'subject #'modb-entity-string-decoder
403 'date #'modb-entity-parse-date-string
404 'to #'modb-entity-address-list-decoder
405 'cc #'modb-entity-address-list-decoder
406 'size nil
407 t #'modb-entity-mime-decoder)
408 ;; string type
409 (modb-set-field-converter 'modb-legacy-entity-specializer 'string
410 'message-id nil
411 'number nil ; not supported
412 'references nil
413 'from #'modb-entity-string-decoder
414 'subject #'modb-entity-string-decoder
415 'date nil
416 'size nil ; not supported
417 t #'modb-entity-mime-decoder)
420 (defmacro modb-legacy-entity-field-index (field)
421 `(cdr (assq ,field modb-legacy-entity-field-indices)))
423 (defsubst modb-legacy-entity-set-field (entity field value &optional as-is)
424 (when entity
425 (let (index)
426 (unless as-is
427 (setq value (modb-convert-field-value
428 modb-legacy-entity-normalizer
429 field value)))
430 (cond ((memq field '(message-id :message-id))
431 (setcar entity value))
432 ((setq index (modb-legacy-entity-field-index field))
433 (aset (cdr entity) index value))
435 (setq index (modb-legacy-entity-field-index :extra))
436 (let ((extras (and entity (aref (cdr entity) index)))
437 extra)
438 (if (setq extra (assoc (symbol-name field) extras))
439 (setcdr extra value)
440 (aset (cdr entity) index (cons (cons (symbol-name field)
441 value) extras)))))))))
443 (defsubst modb-legacy-make-message-entity (args)
444 "Make an message entity."
445 (let ((entity (cons nil (make-vector 9 nil)))
446 field value)
447 (while args
448 (setq field (pop args)
449 value (pop args))
450 (when value
451 (modb-legacy-entity-set-field entity field value)))
452 entity))
454 (luna-define-method elmo-msgdb-make-message-entity
455 ((handler modb-legacy-entity-handler) args)
456 (modb-legacy-make-message-entity args))
458 (luna-define-method elmo-msgdb-create-message-entity-from-buffer
459 ((handler modb-legacy-entity-handler) number args)
460 (let ((extras elmo-msgdb-extra-fields)
461 (default-mime-charset default-mime-charset)
462 entity message-id references from subject to cc date
463 extra field-body charset size)
464 (save-excursion
465 (setq entity (modb-legacy-make-message-entity args))
466 (set-buffer-multibyte default-enable-multibyte-characters)
467 (setq message-id (elmo-msgdb-get-message-id-from-buffer))
468 (and (setq charset (cdr (assoc "charset" (mime-read-Content-Type))))
469 (setq charset (intern-soft charset))
470 (setq default-mime-charset charset))
471 (setq references
472 (elmo-msgdb-get-references-from-buffer)
473 from (elmo-replace-in-string
474 (elmo-mime-string (or (elmo-field-body "from")
475 elmo-no-from))
476 "\t" " ")
477 subject (elmo-replace-in-string
478 (elmo-mime-string (or (elmo-field-body "subject")
479 elmo-no-subject))
480 "\t" " ")
481 date (elmo-decoded-field-body "date")
482 to (mapconcat 'identity (elmo-multiple-field-body "to") ",")
483 cc (mapconcat 'identity (elmo-multiple-field-body "cc") ","))
484 (unless (elmo-msgdb-message-entity-field handler entity 'size)
485 (if (setq size (elmo-field-body "content-length"))
486 (setq size (string-to-number size))
487 (setq size 0)))
488 (while extras
489 (if (setq field-body (elmo-field-body (car extras)))
490 (modb-legacy-entity-set-field
491 entity (intern (downcase (car extras))) field-body 'as-is))
492 (setq extras (cdr extras)))
493 (dolist (field '(message-id number references from subject
494 date to cc size))
495 (when (symbol-value field)
496 (modb-legacy-entity-set-field
497 entity field (symbol-value field) 'as-is)))
498 entity)))
500 (luna-define-method elmo-msgdb-message-entity-number
501 ((handler modb-legacy-entity-handler) entity)
502 (and entity (aref (cdr entity) 0)))
504 (luna-define-method elmo-msgdb-message-entity-set-number
505 ((handler modb-legacy-entity-handler) entity number)
506 (and entity (aset (cdr entity) 0 number)))
508 (luna-define-method elmo-msgdb-message-entity-field
509 ((handler modb-legacy-entity-handler) entity field &optional type)
510 (and entity
511 (let (index)
512 (modb-convert-field-value
513 modb-legacy-entity-specializer
514 field
515 (cond ((memq field '(message-id :message-id))
516 (car entity))
517 ((setq index (modb-legacy-entity-field-index field))
518 (aref (cdr entity) index))
520 (setq index (modb-legacy-entity-field-index :extra))
521 (cdr (assoc (symbol-name field)
522 (aref (cdr entity) index)))))
523 type))))
525 (luna-define-method elmo-msgdb-message-entity-set-field
526 ((handler modb-legacy-entity-handler) entity field value)
527 (modb-legacy-entity-set-field entity field value))
529 (luna-define-method elmo-msgdb-copy-message-entity
530 ((handler modb-legacy-entity-handler) entity &optional make-handler)
531 (if make-handler
532 (let ((copy (elmo-msgdb-make-message-entity make-handler)))
533 (dolist (field (append '(message-id number references from subject
534 date to cc size)
535 (mapcar (lambda (extra) (intern (car extra)))
536 (aref (cdr entity) 8))))
537 (elmo-msgdb-message-entity-set-field
538 make-handler copy field
539 (elmo-msgdb-message-entity-field handler entity field)))
540 copy)
541 (cons (car entity)
542 (copy-sequence (cdr entity)))))
544 (luna-define-method elmo-msgdb-message-match-condition
545 ((handler modb-entity-handler) condition entity)
546 (let ((key (elmo-filter-key condition))
547 (case-fold-search t)
548 field-value)
549 (cond
550 ((or (string= key "since")
551 (string= key "before"))
552 (let ((field-date (elmo-msgdb-message-entity-field
553 handler entity 'date))
554 (specified-date
555 (elmo-datevec-to-time
556 (elmo-date-get-datevec
557 (elmo-filter-value condition)))))
558 (if (string= key "since")
559 (not (elmo-time< field-date specified-date))
560 (elmo-time< field-date specified-date))))
561 ((or (string= key "larger")
562 (string= key "smaller"))
563 (let ((bytes (elmo-msgdb-message-entity-field handler entity 'size))
564 (threshold (string-to-number (elmo-filter-value condition))))
565 (if (string= key "larger")
566 (> bytes threshold)
567 (< bytes threshold))))
568 ((setq field-value (elmo-msgdb-message-entity-field handler
569 entity
570 (intern key)
571 'string))
572 (and (stringp field-value)
573 (string-match (elmo-filter-value condition) field-value)))
575 condition))))
578 ;; Standard implementation.
579 (eval-and-compile
580 (luna-define-class modb-standard-entity-handler (modb-entity-handler)))
582 (defconst modb-standard-entity-field-slots
583 '(number
584 from
585 subject
586 date
589 content-type
590 references
591 size
592 score
593 extra))
595 (defconst modb-standard-entity-field-indices
596 (modb-entity-create-field-indices modb-standard-entity-field-slots))
598 (defvar modb-standard-entity-normalizer nil)
599 (modb-set-field-converter 'modb-standard-entity-normalizer nil
600 'messgae-id nil
601 'number nil
602 'date #'modb-entity-parse-date-string
603 'to #'modb-entity-parse-address-string
604 'cc #'modb-entity-parse-address-string
605 'references nil
606 'size nil
607 'score nil
608 t #'modb-entity-encode-string-recursive)
610 (defvar modb-standard-entity-specializer nil)
611 (modb-set-field-converter 'modb-standard-entity-specializer nil
612 'messgae-id nil
613 'number nil
614 'date nil
615 'references nil
616 'size nil
617 'score nil
618 t #'modb-entity-decode-string-recursive)
619 (modb-set-field-converter 'modb-standard-entity-specializer 'string
620 'messgae-id nil
621 'number nil
622 'date #'modb-entity-make-date-string
623 'to #'modb-entity-make-address-string
624 'cc #'modb-entity-make-address-string
625 'references nil
626 'size nil
627 'score nil
628 'ml-info #'modb-entity-make-mailing-list-info-string
629 t #'modb-entity-decode-string-recursive)
631 (defmacro modb-standard-entity-field-index (field)
632 `(cdr (assq ,field modb-standard-entity-field-indices)))
634 (defsubst modb-standard-entity-set-field (entity field value &optional as-is)
635 (when entity
636 (let (index)
637 (unless as-is
638 (let ((elmo-mime-charset
639 (modb-entity-handler-mime-charset (car entity))))
640 (setq value (modb-convert-field-value modb-standard-entity-normalizer
641 field value))))
642 (cond ((memq field '(message-id :message-id))
643 (setcar (cdr entity) value))
644 ((setq index (modb-standard-entity-field-index field))
645 (aset (cdr (cdr entity)) index value))
647 (setq index (modb-standard-entity-field-index :extra))
648 (let ((extras (aref (cdr (cdr entity)) index))
649 cell)
650 (if (setq cell (assq field extras))
651 (setcdr cell value)
652 (aset (cdr (cdr entity))
653 index
654 (cons (cons field value) extras)))))))))
656 (defsubst modb-standard-make-message-entity (handler args)
657 (let ((entity (cons handler
658 (cons nil
659 (make-vector
660 (length modb-standard-entity-field-slots)
661 nil))))
662 field value)
663 (while args
664 (setq field (pop args)
665 value (pop args))
666 (when value
667 (modb-standard-entity-set-field entity field value)))
668 entity))
670 (luna-define-method elmo-msgdb-make-message-entity
671 ((handler modb-standard-entity-handler) args)
672 (modb-standard-make-message-entity handler args))
674 (luna-define-method elmo-msgdb-message-entity-number
675 ((handler modb-standard-entity-handler) entity)
676 (and entity (aref (cdr (cdr entity)) 0)))
678 (luna-define-method elmo-msgdb-message-entity-set-number
679 ((handler modb-standard-entity-handler) entity number)
680 (and entity (aset (cdr (cdr entity)) 0 number)))
682 (luna-define-method elmo-msgdb-message-entity-field
683 ((handler modb-standard-entity-handler) entity field &optional type)
684 (and entity
685 (let ((elmo-mime-charset
686 (modb-entity-handler-mime-charset handler))
687 index)
688 (modb-convert-field-value
689 modb-standard-entity-specializer
690 field
691 (cond ((memq field '(message-id :message-id))
692 (car (cdr entity)))
693 ((setq index (modb-standard-entity-field-index field))
694 (aref (cdr (cdr entity)) index))
696 (setq index (modb-standard-entity-field-index :extra))
697 (cdr (assq field (aref (cdr (cdr entity)) index)))))
698 type))))
700 (luna-define-method elmo-msgdb-message-entity-set-field
701 ((handler modb-standard-entity-handler) entity field value)
702 (modb-standard-entity-set-field entity field value))
704 (luna-define-method elmo-msgdb-copy-message-entity
705 ((handler modb-standard-entity-handler) entity &optional make-handler)
706 (if make-handler
707 (let ((copy (elmo-msgdb-make-message-entity make-handler)))
708 (dolist (field (nconc
709 (delq 'extra
710 (copy-sequence modb-standard-entity-field-slots))
711 (mapcar 'car
712 (aref
713 (cdr (cdr entity))
714 (modb-standard-entity-field-index :extra)))
715 '(message-id)))
716 (elmo-msgdb-message-entity-set-field
717 make-handler copy field
718 (elmo-msgdb-message-entity-field handler entity field)))
719 copy)
720 (cons handler
721 (cons (car (cdr entity))
722 (copy-sequence (cdr (cdr entity)))))))
724 (luna-define-method elmo-msgdb-create-message-entity-from-buffer
725 ((handler modb-standard-entity-handler) number args)
726 (let (entity)
727 (save-excursion
728 (set-buffer-multibyte default-enable-multibyte-characters)
729 (setq entity
730 (modb-standard-make-message-entity
731 handler
732 (append
733 args
734 (list
735 :number
736 number
737 :message-id
738 (elmo-msgdb-get-message-id-from-buffer)
739 :references
740 (elmo-msgdb-get-references-from-buffer)
741 :from
742 (elmo-replace-in-string
743 (or (elmo-decoded-field-body "from" 'summary)
744 elmo-no-from)
745 "\t" " ")
746 :subject
747 (elmo-replace-in-string
748 (or (elmo-decoded-field-body "subject" 'summary)
749 elmo-no-subject)
750 "\t" " ")
751 :date
752 (elmo-decoded-field-body "date" 'summary)
754 (mapconcat
755 (lambda (field-body)
756 (mime-decode-field-body field-body "to" 'summary))
757 (elmo-multiple-field-body "to") ",")
759 (mapconcat
760 (lambda (field-body)
761 (mime-decode-field-body field-body "cc" 'summary))
762 (elmo-multiple-field-body "cc") ",")
763 :content-type
764 (elmo-decoded-field-body "content-type" 'summary)
765 :size
766 (let ((size (elmo-field-body "content-length")))
767 (if size
768 (string-to-number size)
769 (or (plist-get args :size) 0)))))))
770 (let (field-name field-body extractor)
771 (dolist (extra (cons "newsgroups" elmo-msgdb-extra-fields))
772 (setq field-name (intern (downcase extra))
773 extractor (nth 1 (assq field-name
774 modb-entity-field-extractor-alist))
775 field-body (if extractor
776 (funcall extractor field-name)
777 (elmo-decoded-field-body extra 'summary)))
778 (when field-body
779 (modb-standard-entity-set-field entity field-name field-body))))
780 entity)))
783 ;; mailing list info handling
784 (defun modb-entity-extract-mailing-list-info (field)
785 (let* ((getter (lambda (field)
786 (elmo-decoded-field-body (symbol-name field) 'summary)))
787 (name (elmo-find-list-match-value
788 elmo-mailing-list-name-spec-list
789 getter))
790 (count (elmo-find-list-match-value
791 elmo-mailing-list-count-spec-list
792 getter)))
793 (when (or name count)
794 (cons name (and count (string-to-number count))))))
796 (defun modb-entity-ml-info-real-fields (field)
797 (elmo-uniq-list
798 (mapcar (lambda (entry)
799 (symbol-name (if (consp entry) (car entry) entry)))
800 (append elmo-mailing-list-name-spec-list
801 elmo-mailing-list-count-spec-list))))
803 (defun modb-entity-make-mailing-list-info-string (field value)
804 (when (car value)
805 (format (if (cdr value) "(%s %05.0f)" "(%s)")
806 (elmo-msgdb-get-decoded-cache (car value))
807 (cdr value))))
809 ;; message buffer handler
810 (eval-and-compile
811 (luna-define-class modb-buffer-entity-handler (modb-entity-handler)))
813 (defvar modb-buffer-entity-specializer nil)
814 (modb-set-field-converter 'modb-buffer-entity-specializer nil
815 'date #'elmo-time-parse-date-string)
817 (luna-define-method elmo-msgdb-make-message-entity
818 ((handler modb-buffer-entity-handler) args)
819 (cons handler (cons (or (plist-get args :number)
820 (plist-get args 'number))
821 (or (plist-get args :buffer)
822 (plist-get args 'buffer)
823 (current-buffer)))))
825 (luna-define-method elmo-msgdb-message-entity-number
826 ((handler modb-buffer-entity-handler) entity)
827 (car (cdr entity)))
829 (luna-define-method elmo-msgdb-message-entity-set-number
830 ((handler modb-buffer-entity-handler) entity number)
831 (and entity (setcar (cdr entity) number)))
833 (luna-define-method elmo-msgdb-message-entity-field
834 ((handler modb-buffer-entity-handler) entity field &optional type)
835 (and entity
836 (let ((elmo-mime-charset
837 (modb-entity-handler-mime-charset handler)))
838 (modb-convert-field-value
839 modb-buffer-entity-specializer
840 field
841 (if (memq field '(number :number))
842 (car (cdr entity))
843 (with-current-buffer (cdr (cdr entity))
844 (let ((extractor
845 (nth 1 (assq field modb-entity-field-extractor-alist))))
846 (if extractor
847 (funcall extractor field)
848 (mapconcat
849 (lambda (field-body)
850 (mime-decode-field-body field-body (symbol-name field)
851 'summary))
852 (elmo-multiple-field-body (symbol-name field))
853 "\n")))))
854 type))))
856 (luna-define-method elmo-msgdb-message-match-condition :around
857 ((handler modb-buffer-entity-handler) condition entity)
858 (let ((key (elmo-filter-key condition))
859 (case-fold-search t))
860 (cond
861 ((string= (elmo-filter-key condition) "body")
862 (with-current-buffer (cdr (cdr entity))
863 (goto-char (point-min))
864 (and (re-search-forward "^$" nil t) ; goto body
865 (search-forward (elmo-filter-value condition) nil t))))
867 (luna-call-next-method)))))
869 (require 'product)
870 (product-provide (provide 'modb-entity) (require 'elmo-version))
872 ;;; modb-entity.el ends here