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