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   entity)
 500
 501 (luna-define-method elmo-msgdb-message-entity-field
 502   ((handler modb-legacy-entity-handler) entity field &optional type)
 503   (and entity
 504        (let (index)
 505          (modb-convert-field-value
 506           modb-legacy-entity-specializer
 507           field
 508           (cond ((memq field '(message-id :message-id))
 509                  (car entity))
 510                 ((setq index (modb-legacy-entity-field-index field))
 511                  (aref (cdr entity) index))
 512                 (t
 513                  (setq index (modb-legacy-entity-field-index :extra))
 514                  (cdr (assoc (symbol-name field)
 515                              (aref (cdr entity) index)))))
 516           type))))
 517
 518 (luna-define-method elmo-msgdb-message-entity-set-field
 519   ((handler modb-legacy-entity-handler) entity field value)
 520   (modb-legacy-entity-set-field entity field value))
 521
 522 (luna-define-method elmo-msgdb-copy-message-entity
 523   ((handler modb-legacy-entity-handler) entity &optional make-handler)
 524   (if make-handler
 525       (let ((copy (elmo-msgdb-make-message-entity make-handler)))
 526         (dolist (field (append '(message-id number references from subject
 527                                             date to cc size)
 528                                (mapcar (lambda (extra) (intern (car extra)))
 529                                        (aref (cdr entity) 8))))
 530           (elmo-msgdb-message-entity-set-field
 531            make-handler copy field
 532            (elmo-msgdb-message-entity-field handler entity field)))
 533         copy)
 534     (cons (car entity)
 535           (copy-sequence (cdr entity)))))
 536
 537 (luna-define-method elmo-msgdb-message-match-condition
 538   ((handler modb-entity-handler) condition entity flags numbers)
 539   (cond
 540    ((vectorp condition)
 541     (elmo-msgdb-match-condition-primitive handler condition
 542                                           entity flags numbers))
 543    ((eq (car condition) 'and)
 544     (let ((lhs (elmo-msgdb-message-match-condition handler
 545                                                    (nth 1 condition)
 546                                                    entity flags numbers)))
 547       (cond
 548        ((elmo-filter-condition-p lhs)
 549         (let ((rhs (elmo-msgdb-message-match-condition
 550                     handler (nth 2 condition) entity flags numbers)))
 551           (cond ((elmo-filter-condition-p rhs)
 552                  (list 'and lhs rhs))
 553                 (rhs
 554                  lhs))))
 555        (lhs
 556         (elmo-msgdb-message-match-condition handler (nth 2 condition)
 557                                             entity flags numbers)))))
 558    ((eq (car condition) 'or)
 559     (let ((lhs (elmo-msgdb-message-match-condition handler (nth 1 condition)
 560                                                    entity flags numbers)))
 561       (cond
 562        ((elmo-filter-condition-p lhs)
 563         (let ((rhs (elmo-msgdb-message-match-condition handler
 564                                                        (nth 2 condition)
 565                                                        entity flags numbers)))
 566           (cond ((elmo-filter-condition-p rhs)
 567                  (list 'or lhs rhs))
 568                 (rhs
 569                  t)
 570                 (t
 571                  lhs))))
 572        (lhs
 573         t)
 574        (t
 575         (elmo-msgdb-message-match-condition handler
 576                                              (nth 2 condition)
 577                                              entity flags numbers)))))))
 578
 579 ;;
 580 (defun elmo-msgdb-match-condition-primitive (handler
 581                                              condition
 582                                              entity
 583                                              flags
 584                                              numbers)
 585   (catch 'unresolved
 586     (let ((key (elmo-filter-key condition))
 587           (case-fold-search t)
 588           result)
 589       (cond
 590        ((string= key "last")
 591         (setq result (<= (length (memq
 592                                   (elmo-msgdb-message-entity-number
 593                                    handler entity)
 594                                   numbers))
 595                          (string-to-int (elmo-filter-value condition)))))
 596        ((string= key "first")
 597         (setq result (< (-
 598                          (length numbers)
 599                          (length (memq
 600                                   (elmo-msgdb-message-entity-number
 601                                    handler entity)
 602                                   numbers)))
 603                         (string-to-int (elmo-filter-value condition)))))
 604        ((string= key "flag")
 605         (setq result
 606               (cond
 607                ((string= (elmo-filter-value condition) "any")
 608                 (or (memq 'important flags)
 609                     (memq 'answered flags)
 610                     (memq 'unread flags)))
 611                ((string= (elmo-filter-value condition) "digest")
 612                 (or (memq 'important flags)
 613                     (memq 'unread flags)))
 614                ((string= (elmo-filter-value condition) "unread")
 615                 (memq 'unread flags))
 616                ((string= (elmo-filter-value condition) "important")
 617                 (memq 'important flags))
 618                ((string= (elmo-filter-value condition) "answered")
 619                 (memq 'answered flags)))))
 620        ((string= key "from")
 621         (setq result (string-match
 622                       (elmo-filter-value condition)
 623                       (elmo-msgdb-message-entity-field
 624                        handler entity 'from))))
 625        ((string= key "subject")
 626         (setq result (string-match
 627                       (elmo-filter-value condition)
 628                       (elmo-msgdb-message-entity-field
 629                        handler entity 'subject))))
 630        ((string= key "to")
 631         (setq result (string-match
 632                       (elmo-filter-value condition)
 633                       (elmo-msgdb-message-entity-field
 634                        handler entity 'to 'string))))
 635        ((string= key "cc")
 636         (setq result (string-match
 637                       (elmo-filter-value condition)
 638                       (elmo-msgdb-message-entity-field
 639                        handler entity 'cc 'string))))
 640        ((or (string= key "since")
 641             (string= key "before"))
 642         (let ((field-date (elmo-msgdb-message-entity-field
 643                            handler entity 'date))
 644               (specified-date
 645                (elmo-datevec-to-time
 646                 (elmo-date-get-datevec
 647                  (elmo-filter-value condition)))))
 648           (setq result (if (string= key "since")
 649                            (not (elmo-time< field-date specified-date))
 650                          (elmo-time< field-date specified-date)))))
 651        ((member key elmo-msgdb-extra-fields)
 652         (let ((extval (elmo-msgdb-message-entity-field handler
 653                                                        entity
 654                                                        (intern key)
 655                                                        'string)))
 656           (when (stringp extval)
 657             (setq result (string-match
 658                           (elmo-filter-value condition)
 659                           extval)))))
 660        (t
 661         (throw 'unresolved condition)))
 662       (if (eq (elmo-filter-type condition) 'unmatch)
 663           (not result)
 664         result))))
 665
 666
 667 ;; Standard implementation.
 668 (eval-and-compile
 669   (luna-define-class modb-standard-entity-handler (modb-entity-handler)))
 670
 671 (defconst modb-standard-entity-field-slots
 672   '(number
 673     from
 674     subject
 675     date
 676     to
 677     cc
 678     content-type
 679     references
 680     size
 681     score
 682     extra))
 683
 684 (defconst modb-standard-entity-field-indices
 685   (modb-entity-create-field-indices modb-standard-entity-field-slots))
 686
 687 (defvar modb-standard-entity-normalizer nil)
 688 (modb-set-field-converter 'modb-standard-entity-normalizer nil
 689   'messgae-id   nil
 690   'number       nil
 691   'date         #'modb-entity-parse-date-string
 692   'to           #'modb-entity-parse-address-string
 693   'cc           #'modb-entity-parse-address-string
 694   'references   nil
 695   'size         nil
 696   'score        nil
 697   t             #'modb-entity-encode-string-recursive)
 698
 699 (defvar modb-standard-entity-specializer nil)
 700 (modb-set-field-converter 'modb-standard-entity-specializer nil
 701   'messgae-id   nil
 702   'number       nil
 703   'date         nil
 704   'references   nil
 705   'size         nil
 706   'score        nil
 707   t             #'modb-entity-decode-string-recursive)
 708 (modb-set-field-converter 'modb-standard-entity-specializer 'string
 709   'messgae-id   nil
 710   'number       nil
 711   'date         #'modb-entity-make-date-string
 712   'to           #'modb-entity-make-address-string
 713   'cc           #'modb-entity-make-address-string
 714   'references   nil
 715   'size         nil
 716   'score        nil
 717   'ml-info      #'modb-entity-make-mailing-list-info-string
 718   t             #'modb-entity-decode-string-recursive)
 719
 720 (defmacro modb-standard-entity-field-index (field)
 721   `(cdr (assq ,field modb-standard-entity-field-indices)))
 722
 723 (defsubst modb-standard-entity-set-field (entity field value &optional as-is)
 724   (when entity
 725     (let (index)
 726       (unless as-is
 727         (let ((elmo-mime-charset
 728                (or (modb-entity-handler-mime-charset-internal (car entity))
 729                    elmo-mime-charset)))
 730           (setq value (modb-convert-field-value modb-standard-entity-normalizer
 731                                                 field value))))
 732       (cond ((memq field '(message-id :message-id))
 733              (setcar (cdr entity) value))
 734             ((setq index (modb-standard-entity-field-index field))
 735              (aset (cdr (cdr entity)) index value))
 736             (t
 737              (setq index (modb-standard-entity-field-index :extra))
 738              (let ((extras (aref (cdr (cdr entity)) index))
 739                    cell)
 740                (if (setq cell (assq field extras))
 741                    (setcdr cell value)
 742                  (aset (cdr (cdr entity))
 743                        index
 744                        (cons (cons field value) extras)))))))))
 745
 746 (defsubst modb-standard-make-message-entity (handler args)
 747   (let ((entity (cons handler
 748                       (cons nil
 749                             (make-vector
 750                              (length modb-standard-entity-field-slots)
 751                              nil))))
 752         field value)
 753     (while args
 754       (setq field (pop args)
 755             value (pop args))
 756       (when value
 757         (modb-standard-entity-set-field entity field value)))
 758     entity))
 759
 760 (luna-define-method elmo-msgdb-make-message-entity
 761   ((handler modb-standard-entity-handler) args)
 762   (modb-standard-make-message-entity handler args))
 763
 764 (luna-define-method elmo-msgdb-message-entity-number
 765   ((handler modb-standard-entity-handler) entity)
 766   (and entity (aref (cdr (cdr entity)) 0)))
 767
 768 (luna-define-method elmo-msgdb-message-entity-set-number
 769   ((handler modb-standard-entity-handler) entity number)
 770   (and entity (aset (cdr (cdr entity)) 0 number)))
 771
 772 (luna-define-method elmo-msgdb-message-entity-field
 773   ((handler modb-standard-entity-handler) entity field &optional type)
 774   (and entity
 775        (let ((elmo-mime-charset
 776               (or (modb-entity-handler-mime-charset-internal handler)
 777                   elmo-mime-charset))
 778              index)
 779          (modb-convert-field-value
 780           modb-standard-entity-specializer
 781           field
 782           (cond ((memq field '(message-id :message-id))
 783                  (car (cdr entity)))
 784                 ((setq index (modb-standard-entity-field-index field))
 785                  (aref (cdr (cdr entity)) index))
 786                 (t
 787                  (setq index (modb-standard-entity-field-index :extra))
 788                  (cdr (assq field (aref (cdr (cdr entity)) index)))))
 789           type))))
 790
 791 (luna-define-method elmo-msgdb-message-entity-set-field
 792   ((handler modb-standard-entity-handler) entity field value)
 793   (modb-standard-entity-set-field entity field value))
 794
 795 (luna-define-method elmo-msgdb-copy-message-entity
 796   ((handler modb-standard-entity-handler) entity &optional make-handler)
 797   (if make-handler
 798       (let ((copy (elmo-msgdb-make-message-entity make-handler)))
 799         (dolist (field (nconc
 800                         (delq 'extra
 801                               (copy-sequence modb-standard-entity-field-slots))
 802                         (mapcar 'car
 803                                 (aref
 804                                  (cdr (cdr entity))
 805                                  (modb-standard-entity-field-index :extra)))
 806                         '(message-id)))
 807           (elmo-msgdb-message-entity-set-field
 808            make-handler copy field
 809            (elmo-msgdb-message-entity-field handler entity field)))
 810         copy)
 811     (cons handler
 812           (cons (car (cdr entity))
 813                 (copy-sequence (cdr (cdr entity)))))))
 814
 815 (luna-define-method elmo-msgdb-create-message-entity-from-buffer
 816   ((handler modb-standard-entity-handler) number args)
 817   (let ((default-mime-charset default-mime-charset)
 818         entity content-type charset)
 819     (save-excursion
 820       (set-buffer-multibyte default-enable-multibyte-characters)
 821       (and (setq content-type (elmo-decoded-field-body
 822                                "content-type" 'summary))
 823            (setq charset (mime-content-type-parameter
 824                           (mime-parse-Content-Type content-type) "charset"))
 825            (setq charset (intern-soft charset))
 826            (mime-charset-p charset)
 827            (setq default-mime-charset charset))
 828       (setq entity
 829             (modb-standard-make-message-entity
 830              handler
 831              (append
 832               args
 833               (list
 834                :number
 835                number
 836                :message-id
 837                (elmo-msgdb-get-message-id-from-buffer)
 838                :references
 839                (elmo-msgdb-get-references-from-buffer)
 840                :from
 841                (elmo-replace-in-string
 842                 (or (elmo-decoded-field-body "from" 'summary)
 843                     elmo-no-from)
 844                 "\t" " ")
 845                :subject
 846                (elmo-replace-in-string
 847                 (or (elmo-decoded-field-body "subject" 'summary)
 848                     elmo-no-subject)
 849                 "\t" " ")
 850                :date
 851                (elmo-decoded-field-body "date" 'summary)
 852                :to
 853                (mapconcat
 854                 (lambda (field-body)
 855                   (mime-decode-field-body field-body "to" 'summary))
 856                 (elmo-multiple-field-body "to") ",")
 857                :cc
 858                (mapconcat
 859                 (lambda (field-body)
 860                   (mime-decode-field-body field-body "cc" 'summary))
 861                 (elmo-multiple-field-body "cc") ",")
 862                :content-type
 863                content-type
 864                :size
 865                (let ((size (elmo-field-body "content-length")))
 866                  (if size
 867                      (string-to-int size)
 868                    (or (plist-get args :size) 0)))))))
 869       (let (field-name field-body extractor)
 870         (dolist (extra (cons "newsgroups" elmo-msgdb-extra-fields))
 871           (setq field-name (intern (downcase extra))
 872                 extractor  (cdr (assq field-name
 873                                       modb-entity-field-extractor-alist))
 874                 field-body (if extractor
 875                                (funcall extractor field-name)
 876                              (elmo-decoded-field-body extra 'summary)))
 877           (when field-body
 878             (modb-standard-entity-set-field entity field-name field-body))))
 879       entity)))
 880
 881
 882 ;; mailing list info handling
 883 (defun modb-entity-extract-ml-info-from-x-sequence ()
 884   (let ((sequence (elmo-decoded-field-body "x-sequence" 'summary))
 885         name count)
 886     (when sequence
 887       (elmo-set-list '(name count) (split-string sequence " "))
 888       (cons name count))))
 889
 890 (defun modb-entity-extract-ml-info-from-subject ()
 891   (let ((subject (elmo-decoded-field-body "subject" 'summary)))
 892     (when (and subject
 893                (string-match "^\\s(\\(\\S)+\\)[ :]\\([0-9]+\\)\\s)[ \t]*"
 894                              subject))
 895       (cons (match-string 1 subject) (match-string 2 subject)))))
 896
 897 (defun modb-entity-extract-ml-info-from-return-path ()
 898   (let ((return-path (elmo-decoded-field-body "return-path" 'summary)))
 899     (when (and return-path
 900                (string-match "^<\\([^@>]+\\)-return-\\([0-9]+\\)-"
 901                              return-path))
 902       (cons (match-string 1 return-path)
 903             (match-string 2 return-path)))))
 904
 905 (defun modb-entity-extract-ml-info-from-delivered-to ()
 906   (let ((delivered-to (elmo-decoded-field-body "delivered-to" 'summary)))
 907     (when (and delivered-to
 908                (string-match "^mailing list \\([^@]+\\)@" delivered-to))
 909       (cons (match-string 1 delivered-to) nil))))
 910
 911 (defun modb-entity-extract-ml-info-from-mailing-list ()
 912   (let ((mailing-list (elmo-decoded-field-body "mailing-list" 'summary)))
 913     ;; *-help@, *-owner@, etc.
 914     (when (and mailing-list
 915                (string-match "\\(^\\|; \\)contact \\([^@]+\\)-[^-@]+@"
 916                              mailing-list))
 917       (cons (match-string 2 mailing-list) nil))))
 918
 919 (defvar modb-entity-extract-mailing-list-info-functions
 920   '(modb-entity-extract-ml-info-from-x-sequence
 921     modb-entity-extract-ml-info-from-subject
 922     modb-entity-extract-ml-info-from-return-path
 923     modb-entity-extract-ml-info-from-delivered-to
 924     modb-entity-extract-ml-info-from-mailing-list))
 925
 926 (defun modb-entity-extract-mailing-list-info (field)
 927   (let ((ml-name (elmo-decoded-field-body "x-ml-name" 'summary))
 928         (ml-count (or (elmo-decoded-field-body "x-mail-count" 'summary)
 929                       (elmo-decoded-field-body "x-ml-count" 'summary)))
 930         (functions modb-entity-extract-mailing-list-info-functions)
 931         result)
 932     (while (and functions
 933                 (or (null ml-name) (null ml-count)))
 934       (when (setq result (funcall (car functions)))
 935         (unless ml-name
 936           (setq ml-name (car result)))
 937         (unless ml-count
 938           (setq ml-count (cdr result))))
 939       (setq functions (cdr functions)))
 940     (when (or ml-name ml-count)
 941       (cons (and ml-name (car (split-string ml-name " ")))
 942             (and ml-count (string-to-int ml-count))))))
 943
 944 (defun modb-entity-make-mailing-list-info-string (field value)
 945   (when (car value)
 946     (format (if (cdr value) "(%s %05.0f)" "(%s)")
 947             (elmo-msgdb-get-decoded-cache (car value))
 948             (cdr value))))
 949
 950 (require 'product)
 951 (product-provide (provide 'modb-entity) (require 'elmo-version))
 952
 953 ;;; modb-entity.el ends here