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      ((or (string= key "larger")
 558           (string= key "smaller"))
 559       (let ((bytes (elmo-msgdb-message-entity-field handler entity 'size))
 560             (threshold (string-to-int (elmo-filter-value condition))))
 561         (if (string= key "larger")
 562             (> bytes threshold)
 563           (< bytes threshold))))
 564      ((setq field-value (elmo-msgdb-message-entity-field handler
 565                                                          entity
 566                                                          (intern key)
 567                                                          'string))
 568       (and (stringp field-value)
 569            (string-match (elmo-filter-value condition) field-value)))
 570      (t
 571       condition))))
 572
 573
 574 ;; Standard implementation.
 575 (eval-and-compile
 576   (luna-define-class modb-standard-entity-handler (modb-entity-handler)))
 577
 578 (defconst modb-standard-entity-field-slots
 579   '(number
 580     from
 581     subject
 582     date
 583     to
 584     cc
 585     content-type
 586     references
 587     size
 588     score
 589     extra))
 590
 591 (defconst modb-standard-entity-field-indices
 592   (modb-entity-create-field-indices modb-standard-entity-field-slots))
 593
 594 (defvar modb-standard-entity-normalizer nil)
 595 (modb-set-field-converter 'modb-standard-entity-normalizer nil
 596   'messgae-id   nil
 597   'number       nil
 598   'date         #'modb-entity-parse-date-string
 599   'to           #'modb-entity-parse-address-string
 600   'cc           #'modb-entity-parse-address-string
 601   'references   nil
 602   'size         nil
 603   'score        nil
 604   t             #'modb-entity-encode-string-recursive)
 605
 606 (defvar modb-standard-entity-specializer nil)
 607 (modb-set-field-converter 'modb-standard-entity-specializer nil
 608   'messgae-id   nil
 609   'number       nil
 610   'date         nil
 611   'references   nil
 612   'size         nil
 613   'score        nil
 614   t             #'modb-entity-decode-string-recursive)
 615 (modb-set-field-converter 'modb-standard-entity-specializer 'string
 616   'messgae-id   nil
 617   'number       nil
 618   'date         #'modb-entity-make-date-string
 619   'to           #'modb-entity-make-address-string
 620   'cc           #'modb-entity-make-address-string
 621   'references   nil
 622   'size         nil
 623   'score        nil
 624   'ml-info      #'modb-entity-make-mailing-list-info-string
 625   t             #'modb-entity-decode-string-recursive)
 626
 627 (defmacro modb-standard-entity-field-index (field)
 628   `(cdr (assq ,field modb-standard-entity-field-indices)))
 629
 630 (defsubst modb-standard-entity-set-field (entity field value &optional as-is)
 631   (when entity
 632     (let (index)
 633       (unless as-is
 634         (let ((elmo-mime-charset
 635                (modb-entity-handler-mime-charset (car entity))))
 636           (setq value (modb-convert-field-value modb-standard-entity-normalizer
 637                                                 field value))))
 638       (cond ((memq field '(message-id :message-id))
 639              (setcar (cdr entity) value))
 640             ((setq index (modb-standard-entity-field-index field))
 641              (aset (cdr (cdr entity)) index value))
 642             (t
 643              (setq index (modb-standard-entity-field-index :extra))
 644              (let ((extras (aref (cdr (cdr entity)) index))
 645                    cell)
 646                (if (setq cell (assq field extras))
 647                    (setcdr cell value)
 648                  (aset (cdr (cdr entity))
 649                        index
 650                        (cons (cons field value) extras)))))))))
 651
 652 (defsubst modb-standard-make-message-entity (handler args)
 653   (let ((entity (cons handler
 654                       (cons nil
 655                             (make-vector
 656                              (length modb-standard-entity-field-slots)
 657                              nil))))
 658         field value)
 659     (while args
 660       (setq field (pop args)
 661             value (pop args))
 662       (when value
 663         (modb-standard-entity-set-field entity field value)))
 664     entity))
 665
 666 (luna-define-method elmo-msgdb-make-message-entity
 667   ((handler modb-standard-entity-handler) args)
 668   (modb-standard-make-message-entity handler args))
 669
 670 (luna-define-method elmo-msgdb-message-entity-number
 671   ((handler modb-standard-entity-handler) entity)
 672   (and entity (aref (cdr (cdr entity)) 0)))
 673
 674 (luna-define-method elmo-msgdb-message-entity-set-number
 675   ((handler modb-standard-entity-handler) entity number)
 676   (and entity (aset (cdr (cdr entity)) 0 number)))
 677
 678 (luna-define-method elmo-msgdb-message-entity-field
 679   ((handler modb-standard-entity-handler) entity field &optional type)
 680   (and entity
 681        (let ((elmo-mime-charset
 682               (modb-entity-handler-mime-charset handler))
 683              index)
 684          (modb-convert-field-value
 685           modb-standard-entity-specializer
 686           field
 687           (cond ((memq field '(message-id :message-id))
 688                  (car (cdr entity)))
 689                 ((setq index (modb-standard-entity-field-index field))
 690                  (aref (cdr (cdr entity)) index))
 691                 (t
 692                  (setq index (modb-standard-entity-field-index :extra))
 693                  (cdr (assq field (aref (cdr (cdr entity)) index)))))
 694           type))))
 695
 696 (luna-define-method elmo-msgdb-message-entity-set-field
 697   ((handler modb-standard-entity-handler) entity field value)
 698   (modb-standard-entity-set-field entity field value))
 699
 700 (luna-define-method elmo-msgdb-copy-message-entity
 701   ((handler modb-standard-entity-handler) entity &optional make-handler)
 702   (if make-handler
 703       (let ((copy (elmo-msgdb-make-message-entity make-handler)))
 704         (dolist (field (nconc
 705                         (delq 'extra
 706                               (copy-sequence modb-standard-entity-field-slots))
 707                         (mapcar 'car
 708                                 (aref
 709                                  (cdr (cdr entity))
 710                                  (modb-standard-entity-field-index :extra)))
 711                         '(message-id)))
 712           (elmo-msgdb-message-entity-set-field
 713            make-handler copy field
 714            (elmo-msgdb-message-entity-field handler entity field)))
 715         copy)
 716     (cons handler
 717           (cons (car (cdr entity))
 718                 (copy-sequence (cdr (cdr entity)))))))
 719
 720 (luna-define-method elmo-msgdb-create-message-entity-from-buffer
 721   ((handler modb-standard-entity-handler) number args)
 722   (let (entity)
 723     (save-excursion
 724       (set-buffer-multibyte default-enable-multibyte-characters)
 725       (setq entity
 726             (modb-standard-make-message-entity
 727              handler
 728              (append
 729               args
 730               (list
 731                :number
 732                number
 733                :message-id
 734                (elmo-msgdb-get-message-id-from-buffer)
 735                :references
 736                (elmo-msgdb-get-references-from-buffer)
 737                :from
 738                (elmo-replace-in-string
 739                 (or (elmo-decoded-field-body "from" 'summary)
 740                     elmo-no-from)
 741                 "\t" " ")
 742                :subject
 743                (elmo-replace-in-string
 744                 (or (elmo-decoded-field-body "subject" 'summary)
 745                     elmo-no-subject)
 746                 "\t" " ")
 747                :date
 748                (elmo-decoded-field-body "date" 'summary)
 749                :to
 750                (mapconcat
 751                 (lambda (field-body)
 752                   (mime-decode-field-body field-body "to" 'summary))
 753                 (elmo-multiple-field-body "to") ",")
 754                :cc
 755                (mapconcat
 756                 (lambda (field-body)
 757                   (mime-decode-field-body field-body "cc" 'summary))
 758                 (elmo-multiple-field-body "cc") ",")
 759                :content-type
 760                (elmo-decoded-field-body "content-type" 'summary)
 761                :size
 762                (let ((size (elmo-field-body "content-length")))
 763                  (if size
 764                      (string-to-int size)
 765                    (or (plist-get args :size) 0)))))))
 766       (let (field-name field-body extractor)
 767         (dolist (extra (cons "newsgroups" elmo-msgdb-extra-fields))
 768           (setq field-name (intern (downcase extra))
 769                 extractor  (cdr (assq field-name
 770                                       modb-entity-field-extractor-alist))
 771                 field-body (if extractor
 772                                (funcall extractor field-name)
 773                              (elmo-decoded-field-body extra 'summary)))
 774           (when field-body
 775             (modb-standard-entity-set-field entity field-name field-body))))
 776       entity)))
 777
 778
 779 ;; mailing list info handling
 780 (defun modb-entity-extract-mailing-list-info (field)
 781   (let* ((getter (lambda (field)
 782                    (elmo-decoded-field-body (symbol-name field) 'summary)))
 783          (name (elmo-find-list-match-value
 784                 elmo-mailing-list-name-spec-list
 785                 getter))
 786          (count (elmo-find-list-match-value
 787                   elmo-mailing-list-count-spec-list
 788                   getter)))
 789     (when (or name count)
 790       (cons name (and count (string-to-number count))))))
 791
 792 (defun modb-entity-make-mailing-list-info-string (field value)
 793   (when (car value)
 794     (format (if (cdr value) "(%s %05.0f)" "(%s)")
 795             (elmo-msgdb-get-decoded-cache (car value))
 796             (cdr value))))
 797
 798 ;; message buffer handler
 799 (eval-and-compile
 800   (luna-define-class modb-buffer-entity-handler (modb-entity-handler)))
 801
 802 (defvar modb-buffer-entity-specializer nil)
 803 (modb-set-field-converter 'modb-buffer-entity-specializer nil
 804   'date #'elmo-time-parse-date-string)
 805
 806 (luna-define-method elmo-msgdb-make-message-entity
 807   ((handler modb-buffer-entity-handler) args)
 808   (cons handler (cons (or (plist-get args :number)
 809                           (plist-get args 'number))
 810                       (or (plist-get args :buffer)
 811                           (plist-get args 'buffer)
 812                           (current-buffer)))))
 813
 814 (luna-define-method elmo-msgdb-message-entity-number
 815   ((handler modb-buffer-entity-handler) entity)
 816   (car (cdr entity)))
 817
 818 (luna-define-method elmo-msgdb-message-entity-set-number
 819   ((handler modb-buffer-entity-handler) entity number)
 820   (and entity (setcar (cdr entity) number)))
 821
 822 (luna-define-method elmo-msgdb-message-entity-field
 823   ((handler modb-buffer-entity-handler) entity field &optional type)
 824   (and entity
 825        (let ((elmo-mime-charset
 826               (modb-entity-handler-mime-charset handler)))
 827          (modb-convert-field-value
 828           modb-buffer-entity-specializer
 829           field
 830           (if (memq field '(number :number))
 831               (car (cdr entity))
 832             (with-current-buffer (cdr (cdr entity))
 833               (let ((extractor (cdr (assq field
 834                                           modb-entity-field-extractor-alist))))
 835                 (if extractor
 836                     (funcall extractor field)
 837                   (mapconcat
 838                    (lambda (field-body)
 839                      (mime-decode-field-body field-body (symbol-name field)
 840                                              'summary))
 841                    (elmo-multiple-field-body (symbol-name field))
 842                    "\n")))))
 843           type))))
 844
 845 (luna-define-method elmo-msgdb-message-match-condition :around
 846   ((handler modb-buffer-entity-handler) condition entity)
 847   (let ((key (elmo-filter-key condition))
 848         (case-fold-search t))
 849     (cond
 850      ((string= (elmo-filter-key condition) "body")
 851       (with-current-buffer (cdr (cdr entity))
 852         (goto-char (point-min))
 853         (and (re-search-forward "^$" nil t)        ; goto body
 854              (search-forward (elmo-filter-value condition) nil t))))
 855      (t
 856       (luna-call-next-method)))))
 857
 858 (require 'product)
 859 (product-provide (provide 'modb-entity) (require 'elmo-version))
 860
 861 ;;; modb-entity.el ends here