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