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