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   (cond ((stringp value)
 330          (elmo-msgdb-get-decoded-cache value))
 331         ((consp value)
 332          (setcar value (modb-entity-decode-string-recursive field (car value)))
 333          (setcdr value (modb-entity-decode-string-recursive field (cdr value)))
 334          value)
 335         (t
 336          value)))
 337
 338 (defun modb-entity-encode-string-recursive (field value)
 339   (cond ((stringp value)
 340          (elmo-with-enable-multibyte
 341            (encode-mime-charset-string value elmo-mime-charset)))
 342         ((consp value)
 343          (setcar value (modb-entity-encode-string-recursive field (car value)))
 344          (setcdr value (modb-entity-encode-string-recursive field (cdr value)))
 345          value)
 346         (t
 347          value)))
 348
 349
 350 (defun modb-entity-create-field-indices (slots)
 351   (let ((index 0)
 352         indices)
 353     (while slots
 354       (setq indices (cons (cons (car slots) index) indices)
 355             index   (1+ index)
 356             slots   (cdr slots)))
 357     (append
 358      indices
 359      (mapcar (lambda (cell)
 360                (cons (intern (concat ":" (symbol-name (car cell))))
 361                      (cdr cell)))
 362              indices))))
 363
 364
 365 ;; Legacy implementation.
 366 (eval-and-compile
 367   (luna-define-class modb-legacy-entity-handler (modb-entity-handler)))
 368
 369 (defconst modb-legacy-entity-field-slots
 370  '(number
 371    references
 372    from
 373    subject
 374    date
 375    to
 376    cc
 377    size
 378    extra))
 379
 380 (defconst modb-legacy-entity-field-indices
 381   (modb-entity-create-field-indices modb-legacy-entity-field-slots))
 382
 383 (defvar modb-legacy-entity-normalizer nil)
 384 (modb-set-field-converter 'modb-legacy-entity-normalizer nil
 385   'message-id   nil
 386   'number       nil
 387   'references   nil
 388   'from         #'modb-entity-string-encoder
 389   'subject      #'modb-entity-string-encoder
 390   'date         #'modb-entity-make-date-string
 391   'to           #'modb-entity-address-list-encoder
 392   'cc           #'modb-entity-address-list-encoder
 393   'size         nil
 394   t             #'modb-entity-mime-encoder)
 395
 396 (defvar modb-legacy-entity-specializer nil)
 397 ;; default type
 398 (modb-set-field-converter 'modb-legacy-entity-specializer nil
 399   'message-id   nil
 400   'number       nil
 401   'references   nil
 402   'from         #'modb-entity-string-decoder
 403   'subject      #'modb-entity-string-decoder
 404   'date         #'modb-entity-parse-date-string
 405   'to           #'modb-entity-address-list-decoder
 406   'cc           #'modb-entity-address-list-decoder
 407   'size         nil
 408   t             #'modb-entity-mime-decoder)
 409 ;; string type
 410 (modb-set-field-converter 'modb-legacy-entity-specializer 'string
 411   'message-id   nil
 412   'number       nil                     ; not supported
 413   'references   nil
 414   'from         #'modb-entity-string-decoder
 415   'subject      #'modb-entity-string-decoder
 416   'date         nil
 417   'size         nil                     ; not supported
 418   t             #'modb-entity-mime-decoder)
 419
 420
 421 (defmacro modb-legacy-entity-field-index (field)
 422   `(cdr (assq ,field modb-legacy-entity-field-indices)))
 423
 424 (defsubst modb-legacy-entity-set-field (entity field value &optional as-is)
 425   (when entity
 426     (let (index)
 427       (unless as-is
 428         (setq value (modb-convert-field-value
 429                      modb-legacy-entity-normalizer
 430                      field value)))
 431       (cond ((memq field '(message-id :message-id))
 432              (setcar entity value))
 433             ((setq index (modb-legacy-entity-field-index field))
 434              (aset (cdr entity) index value))
 435             (t
 436              (setq index (modb-legacy-entity-field-index :extra))
 437              (let ((extras (and entity (aref (cdr entity) index)))
 438                    extra)
 439                (if (setq extra (assoc (symbol-name field) extras))
 440                    (setcdr extra value)
 441                  (aset (cdr entity) index (cons (cons (symbol-name field)
 442                                                       value) extras)))))))))
 443
 444 (defsubst modb-legacy-make-message-entity (args)
 445   "Make an message entity."
 446   (let ((entity (cons nil (make-vector 9 nil)))
 447         field value)
 448     (while args
 449       (setq field (pop args)
 450             value (pop args))
 451       (when value
 452         (modb-legacy-entity-set-field entity field value)))
 453     entity))
 454
 455 (luna-define-method elmo-msgdb-make-message-entity
 456   ((handler modb-legacy-entity-handler) args)
 457   (modb-legacy-make-message-entity args))
 458
 459 (luna-define-method elmo-msgdb-create-message-entity-from-buffer
 460   ((handler modb-legacy-entity-handler) number args)
 461   (let ((extras elmo-msgdb-extra-fields)
 462         (default-mime-charset default-mime-charset)
 463         entity message-id references from subject to cc date
 464         extra field-body charset size)
 465     (save-excursion
 466       (setq entity (modb-legacy-make-message-entity args))
 467       (set-buffer-multibyte default-enable-multibyte-characters)
 468       (setq message-id (elmo-msgdb-get-message-id-from-buffer))
 469       (and (setq charset (cdr (assoc "charset" (mime-read-Content-Type))))
 470            (setq charset (intern-soft charset))
 471            (setq default-mime-charset charset))
 472       (setq references
 473             (elmo-msgdb-get-references-from-buffer)
 474             from (elmo-replace-in-string
 475                   (elmo-mime-string (or (elmo-field-body "from")
 476                                         elmo-no-from))
 477                   "\t" " ")
 478             subject (elmo-replace-in-string
 479                      (elmo-mime-string (or (elmo-field-body "subject")
 480                                            elmo-no-subject))
 481                      "\t" " ")
 482             date (elmo-decoded-field-body "date")
 483             to   (mapconcat 'identity (elmo-multiple-field-body "to") ",")
 484             cc   (mapconcat 'identity (elmo-multiple-field-body "cc") ","))
 485       (unless (elmo-msgdb-message-entity-field handler entity 'size)
 486         (if (setq size (elmo-field-body "content-length"))
 487             (setq size (string-to-int size))
 488           (setq size 0)))
 489       (while extras
 490         (if (setq field-body (elmo-field-body (car extras)))
 491             (modb-legacy-entity-set-field
 492              entity (intern (downcase (car extras))) field-body 'as-is))
 493         (setq extras (cdr extras)))
 494       (dolist (field '(message-id number references from subject
 495                                   date to cc size))
 496         (when (symbol-value field)
 497           (modb-legacy-entity-set-field
 498            entity field (symbol-value field) 'as-is)))
 499       entity)))
 500
 501 (luna-define-method elmo-msgdb-message-entity-number
 502   ((handler modb-legacy-entity-handler) entity)
 503   (and entity (aref (cdr entity) 0)))
 504
 505 (luna-define-method elmo-msgdb-message-entity-set-number
 506   ((handler modb-legacy-entity-handler) entity number)
 507   (and entity (aset (cdr entity) 0 number)))
 508
 509 (luna-define-method elmo-msgdb-message-entity-field
 510   ((handler modb-legacy-entity-handler) entity field &optional type)
 511   (and entity
 512        (let (index)
 513          (modb-convert-field-value
 514           modb-legacy-entity-specializer
 515           field
 516           (cond ((memq field '(message-id :message-id))
 517                  (car entity))
 518                 ((setq index (modb-legacy-entity-field-index field))
 519                  (aref (cdr entity) index))
 520                 (t
 521                  (setq index (modb-legacy-entity-field-index :extra))
 522                  (cdr (assoc (symbol-name field)
 523                              (aref (cdr entity) index)))))
 524           type))))
 525
 526 (luna-define-method elmo-msgdb-message-entity-set-field
 527   ((handler modb-legacy-entity-handler) entity field value)
 528   (modb-legacy-entity-set-field entity field value))
 529
 530 (luna-define-method elmo-msgdb-copy-message-entity
 531   ((handler modb-legacy-entity-handler) entity &optional make-handler)
 532   (if make-handler
 533       (let ((copy (elmo-msgdb-make-message-entity make-handler)))
 534         (dolist (field (append '(message-id number references from subject
 535                                             date to cc size)
 536                                (mapcar (lambda (extra) (intern (car extra)))
 537                                        (aref (cdr entity) 8))))
 538           (elmo-msgdb-message-entity-set-field
 539            make-handler copy field
 540            (elmo-msgdb-message-entity-field handler entity field)))
 541         copy)
 542     (cons (car entity)
 543           (copy-sequence (cdr entity)))))
 544
 545 (luna-define-method elmo-msgdb-message-match-condition
 546   ((handler modb-entity-handler) condition entity)
 547   (let ((key (elmo-filter-key condition))
 548         (case-fold-search t)
 549         field-value)
 550     (cond
 551      ((or (string= key "since")
 552           (string= key "before"))
 553       (let ((field-date (elmo-msgdb-message-entity-field
 554                          handler entity 'date))
 555             (specified-date
 556              (elmo-datevec-to-time
 557               (elmo-date-get-datevec
 558                (elmo-filter-value condition)))))
 559         (if (string= key "since")
 560             (not (elmo-time< field-date specified-date))
 561           (elmo-time< field-date specified-date))))
 562      ((setq field-value (elmo-msgdb-message-entity-field handler
 563                                                          entity
 564                                                          (intern key)
 565                                                          'string))
 566       (and (stringp field-value)
 567            (string-match (elmo-filter-value condition) field-value)))
 568      (t
 569       condition))))
 570
 571
 572 ;; Standard implementation.
 573 (eval-and-compile
 574   (luna-define-class modb-standard-entity-handler (modb-entity-handler)))
 575
 576 (defconst modb-standard-entity-field-slots
 577   '(number
 578     from
 579     subject
 580     date
 581     to
 582     cc
 583     content-type
 584     references
 585     size
 586     score
 587     extra))
 588
 589 (defconst modb-standard-entity-field-indices
 590   (modb-entity-create-field-indices modb-standard-entity-field-slots))
 591
 592 (defvar modb-standard-entity-normalizer nil)
 593 (modb-set-field-converter 'modb-standard-entity-normalizer nil
 594   'messgae-id   nil
 595   'number       nil
 596   'date         #'modb-entity-parse-date-string
 597   'to           #'modb-entity-parse-address-string
 598   'cc           #'modb-entity-parse-address-string
 599   'references   nil
 600   'size         nil
 601   'score        nil
 602   t             #'modb-entity-encode-string-recursive)
 603
 604 (defvar modb-standard-entity-specializer nil)
 605 (modb-set-field-converter 'modb-standard-entity-specializer nil
 606   'messgae-id   nil
 607   'number       nil
 608   'date         nil
 609   'references   nil
 610   'size         nil
 611   'score        nil
 612   t             #'modb-entity-decode-string-recursive)
 613 (modb-set-field-converter 'modb-standard-entity-specializer 'string
 614   'messgae-id   nil
 615   'number       nil
 616   'date         #'modb-entity-make-date-string
 617   'to           #'modb-entity-make-address-string
 618   'cc           #'modb-entity-make-address-string
 619   'references   nil
 620   'size         nil
 621   'score        nil
 622   'ml-info      #'modb-entity-make-mailing-list-info-string
 623   t             #'modb-entity-decode-string-recursive)
 624
 625 (defmacro modb-standard-entity-field-index (field)
 626   `(cdr (assq ,field modb-standard-entity-field-indices)))
 627
 628 (defsubst modb-standard-entity-set-field (entity field value &optional as-is)
 629   (when entity
 630     (let (index)
 631       (unless as-is
 632         (let ((elmo-mime-charset
 633                (modb-entity-handler-mime-charset (car entity))))
 634           (setq value (modb-convert-field-value modb-standard-entity-normalizer
 635                                                 field value))))
 636       (cond ((memq field '(message-id :message-id))
 637              (setcar (cdr entity) value))
 638             ((setq index (modb-standard-entity-field-index field))
 639              (aset (cdr (cdr entity)) index value))
 640             (t
 641              (setq index (modb-standard-entity-field-index :extra))
 642              (let ((extras (aref (cdr (cdr entity)) index))
 643                    cell)
 644                (if (setq cell (assq field extras))
 645                    (setcdr cell value)
 646                  (aset (cdr (cdr entity))
 647                        index
 648                        (cons (cons field value) extras)))))))))
 649
 650 (defsubst modb-standard-make-message-entity (handler args)
 651   (let ((entity (cons handler
 652                       (cons nil
 653                             (make-vector
 654                              (length modb-standard-entity-field-slots)
 655                              nil))))
 656         field value)
 657     (while args
 658       (setq field (pop args)
 659             value (pop args))
 660       (when value
 661         (modb-standard-entity-set-field entity field value)))
 662     entity))
 663
 664 (luna-define-method elmo-msgdb-make-message-entity
 665   ((handler modb-standard-entity-handler) args)
 666   (modb-standard-make-message-entity handler args))
 667
 668 (luna-define-method elmo-msgdb-message-entity-number
 669   ((handler modb-standard-entity-handler) entity)
 670   (and entity (aref (cdr (cdr entity)) 0)))
 671
 672 (luna-define-method elmo-msgdb-message-entity-set-number
 673   ((handler modb-standard-entity-handler) entity number)
 674   (and entity (aset (cdr (cdr entity)) 0 number)))
 675
 676 (luna-define-method elmo-msgdb-message-entity-field
 677   ((handler modb-standard-entity-handler) entity field &optional type)
 678   (and entity
 679        (let ((elmo-mime-charset
 680               (modb-entity-handler-mime-charset handler))
 681              index)
 682          (modb-convert-field-value
 683           modb-standard-entity-specializer
 684           field
 685           (cond ((memq field '(message-id :message-id))
 686                  (car (cdr entity)))
 687                 ((setq index (modb-standard-entity-field-index field))
 688                  (aref (cdr (cdr entity)) index))
 689                 (t
 690                  (setq index (modb-standard-entity-field-index :extra))
 691                  (cdr (assq field (aref (cdr (cdr entity)) index)))))
 692           type))))
 693
 694 (luna-define-method elmo-msgdb-message-entity-set-field
 695   ((handler modb-standard-entity-handler) entity field value)
 696   (modb-standard-entity-set-field entity field value))
 697
 698 (luna-define-method elmo-msgdb-copy-message-entity
 699   ((handler modb-standard-entity-handler) entity &optional make-handler)
 700   (if make-handler
 701       (let ((copy (elmo-msgdb-make-message-entity make-handler)))
 702         (dolist (field (nconc
 703                         (delq 'extra
 704                               (copy-sequence modb-standard-entity-field-slots))
 705                         (mapcar 'car
 706                                 (aref
 707                                  (cdr (cdr entity))
 708                                  (modb-standard-entity-field-index :extra)))
 709                         '(message-id)))
 710           (elmo-msgdb-message-entity-set-field
 711            make-handler copy field
 712            (elmo-msgdb-message-entity-field handler entity field)))
 713         copy)
 714     (cons handler
 715           (cons (car (cdr entity))
 716                 (copy-sequence (cdr (cdr entity)))))))
 717
 718 (luna-define-method elmo-msgdb-create-message-entity-from-buffer
 719   ((handler modb-standard-entity-handler) number args)
 720   (let ((default-mime-charset default-mime-charset)
 721         entity content-type charset)
 722     (save-excursion
 723       (set-buffer-multibyte default-enable-multibyte-characters)
 724       (and (setq content-type (elmo-decoded-field-body
 725                                "content-type" 'summary))
 726            (setq charset (mime-content-type-parameter
 727                           (mime-parse-Content-Type content-type) "charset"))
 728            (setq charset (intern-soft charset))
 729            (mime-charset-p charset)
 730            (setq default-mime-charset charset))
 731       (setq entity
 732             (modb-standard-make-message-entity
 733              handler
 734              (append
 735               args
 736               (list
 737                :number
 738                number
 739                :message-id
 740                (elmo-msgdb-get-message-id-from-buffer)
 741                :references
 742                (elmo-msgdb-get-references-from-buffer)
 743                :from
 744                (elmo-replace-in-string
 745                 (or (elmo-decoded-field-body "from" 'summary)
 746                     elmo-no-from)
 747                 "\t" " ")
 748                :subject
 749                (elmo-replace-in-string
 750                 (or (elmo-decoded-field-body "subject" 'summary)
 751                     elmo-no-subject)
 752                 "\t" " ")
 753                :date
 754                (elmo-decoded-field-body "date" 'summary)
 755                :to
 756                (mapconcat
 757                 (lambda (field-body)
 758                   (mime-decode-field-body field-body "to" 'summary))
 759                 (elmo-multiple-field-body "to") ",")
 760                :cc
 761                (mapconcat
 762                 (lambda (field-body)
 763                   (mime-decode-field-body field-body "cc" 'summary))
 764                 (elmo-multiple-field-body "cc") ",")
 765                :content-type
 766                content-type
 767                :size
 768                (let ((size (elmo-field-body "content-length")))
 769                  (if size
 770                      (string-to-int size)
 771                    (or (plist-get args :size) 0)))))))
 772       (let (field-name field-body extractor)
 773         (dolist (extra (cons "newsgroups" elmo-msgdb-extra-fields))
 774           (setq field-name (intern (downcase extra))
 775                 extractor  (cdr (assq field-name
 776                                       modb-entity-field-extractor-alist))
 777                 field-body (if extractor
 778                                (funcall extractor field-name)
 779                              (elmo-decoded-field-body extra 'summary)))
 780           (when field-body
 781             (modb-standard-entity-set-field entity field-name field-body))))
 782       entity)))
 783
 784
 785 ;; mailing list info handling
 786 (defun modb-entity-extract-ml-info-from-x-sequence ()
 787   (let ((sequence (elmo-decoded-field-body "x-sequence" 'summary))
 788         name count)
 789     (when sequence
 790       (elmo-set-list '(name count) (split-string sequence " "))
 791       (cons name count))))
 792
 793 (defun modb-entity-extract-ml-info-from-subject ()
 794   (let ((subject (elmo-decoded-field-body "subject" 'summary)))
 795     (when (and subject
 796                (string-match "^\\s(\\(\\S)+\\)[ :]\\([0-9]+\\)\\s)[ \t]*"
 797                              subject))
 798       (cons (match-string 1 subject) (match-string 2 subject)))))
 799
 800 (defun modb-entity-extract-ml-info-from-return-path ()
 801   (let ((return-path (elmo-decoded-field-body "return-path" 'summary)))
 802     (when (and return-path
 803                (string-match "^<\\([^@>]+\\)-return-\\([0-9]+\\)-"
 804                              return-path))
 805       (cons (match-string 1 return-path)
 806             (match-string 2 return-path)))))
 807
 808 (defun modb-entity-extract-ml-info-from-delivered-to ()
 809   (let ((delivered-to (elmo-decoded-field-body "delivered-to" 'summary)))
 810     (when (and delivered-to
 811                (string-match "^mailing list \\([^@]+\\)@" delivered-to))
 812       (cons (match-string 1 delivered-to) nil))))
 813
 814 (defun modb-entity-extract-ml-info-from-mailing-list ()
 815   (let ((mailing-list (elmo-decoded-field-body "mailing-list" 'summary)))
 816     ;; *-help@, *-owner@, etc.
 817     (when (and mailing-list
 818                (string-match "\\(^\\|; \\)contact \\([^@]+\\)-[^-@]+@"
 819                              mailing-list))
 820       (cons (match-string 2 mailing-list) nil))))
 821
 822 (defvar modb-entity-extract-mailing-list-info-functions
 823   '(modb-entity-extract-ml-info-from-x-sequence
 824     modb-entity-extract-ml-info-from-subject
 825     modb-entity-extract-ml-info-from-return-path
 826     modb-entity-extract-ml-info-from-delivered-to
 827     modb-entity-extract-ml-info-from-mailing-list))
 828
 829 (defun modb-entity-extract-mailing-list-info (field)
 830   (let ((ml-name (elmo-decoded-field-body "x-ml-name" 'summary))
 831         (ml-count (or (elmo-decoded-field-body "x-mail-count" 'summary)
 832                       (elmo-decoded-field-body "x-ml-count" 'summary)))
 833         (functions modb-entity-extract-mailing-list-info-functions)
 834         result)
 835     (while (and functions
 836                 (or (null ml-name) (null ml-count)))
 837       (when (setq result (funcall (car functions)))
 838         (unless ml-name
 839           (setq ml-name (car result)))
 840         (unless ml-count
 841           (setq ml-count (cdr result))))
 842       (setq functions (cdr functions)))
 843     (when (or ml-name ml-count)
 844       (cons (and ml-name (car (split-string ml-name " ")))
 845             (and ml-count (string-to-int ml-count))))))
 846
 847 (defun modb-entity-make-mailing-list-info-string (field value)
 848   (when (car value)
 849     (format (if (cdr value) "(%s %05.0f)" "(%s)")
 850             (elmo-msgdb-get-decoded-cache (car value))
 851             (cdr value))))
 852
 853 ;; message buffer handler
 854 (eval-and-compile
 855   (luna-define-class modb-buffer-entity-handler (modb-entity-handler)))
 856
 857 (defvar modb-buffer-entity-specializer nil)
 858 (modb-set-field-converter 'modb-buffer-entity-specializer nil
 859   'date #'elmo-time-parse-date-string)
 860
 861 (luna-define-method elmo-msgdb-make-message-entity
 862   ((handler modb-buffer-entity-handler) args)
 863   (cons handler (cons (or (plist-get args :number)
 864                           (plist-get args 'number))
 865                       (or (plist-get args :buffer)
 866                           (plist-get args 'buffer)
 867                           (current-buffer)))))
 868
 869 (luna-define-method elmo-msgdb-message-entity-number
 870   ((handler modb-buffer-entity-handler) entity)
 871   (car (cdr entity)))
 872
 873 (luna-define-method elmo-msgdb-message-entity-set-number
 874   ((handler modb-buffer-entity-handler) entity number)
 875   (and entity (setcar (cdr entity) number)))
 876
 877 (luna-define-method elmo-msgdb-message-entity-field
 878   ((handler modb-buffer-entity-handler) entity field &optional type)
 879   (and entity
 880        (let ((elmo-mime-charset
 881               (modb-entity-handler-mime-charset handler)))
 882          (modb-convert-field-value
 883           modb-buffer-entity-specializer
 884           field
 885           (if (memq field '(number :number))
 886               (car (cdr entity))
 887             (with-current-buffer (cdr (cdr entity))
 888               (let ((extractor (cdr (assq field
 889                                           modb-entity-field-extractor-alist))))
 890                 (if extractor
 891                     (funcall extractor field)
 892                   (mapconcat
 893                    (lambda (field-body)
 894                      (mime-decode-field-body field-body (symbol-name field)
 895                                              'summary))
 896                    (elmo-multiple-field-body (symbol-name field))
 897                    "\n")))))
 898           type))))
 899
 900 (luna-define-method elmo-msgdb-message-match-condition :around
 901   ((handler modb-buffer-entity-handler) condition entity)
 902   (let ((key (elmo-filter-key condition))
 903         (case-fold-search t))
 904     (cond
 905      ((string= (elmo-filter-key condition) "body")
 906       (with-current-buffer (cdr (cdr entity))
 907         (goto-char (point-min))
 908         (and (re-search-forward "^$" nil t)        ; goto body
 909              (search-forward (elmo-filter-value condition) nil t))))
 910      (t
 911       (luna-call-next-method)))))
 912
 913 (require 'product)
 914 (product-provide (provide 'modb-entity) (require 'elmo-version))
 915
 916 ;;; modb-entity.el ends here