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