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 elmo-msgdb-prefer-in-reply-to-for-parent nil
  47   "*Non-nil to prefer In-Reply-To header for finding parent message on thread,
  48 rather than References header."
  49   :type 'boolean
  50   :group 'elmo)
  51
  52 (defvar modb-entity-default-cache-internal nil)
  53
  54 (defun elmo-message-entity-handler (&optional entity)
  55   "Get modb entity handler instance which corresponds to the ENTITY."
  56   (if (and entity
  57            (car-safe entity)
  58            (not (eq (car entity) t))
  59            (not (stringp (car entity))))
  60       (car entity)
  61     (or modb-entity-default-cache-internal
  62         (setq modb-entity-default-cache-internal
  63               (luna-make-entity modb-entity-default-handler)))))
  64
  65 (luna-define-generic elmo-msgdb-make-message-entity (handler &rest args)
  66   "Make a message entity using HANDLER.")
  67
  68 (luna-define-generic elmo-msgdb-message-entity-number (handler entity)
  69   "Number of the ENTITY.")
  70
  71 (luna-define-generic elmo-msgdb-message-entity-set-number (handler
  72                                                            entity number)
  73   "Set number of the ENTITY.")
  74
  75 (luna-define-generic elmo-msgdb-message-entity-field (handler
  76                                                       entity field
  77                                                       &optional decode)
  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 DECODE is no-nil, the field value is decoded.")
  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   "Copy message entity.
 101 HANDLER is the message entity handler.
 102 ENTITY is the message entity structure.")
 103
 104 (luna-define-generic elmo-msgdb-create-message-entity-from-file (handler
 105                                                                  number
 106                                                                  file)
 107   "Create message entity from file.
 108 HANDLER is the message entity handler.
 109 NUMBER is the number of the newly created message entity.
 110 FILE is the message file.")
 111
 112 (luna-define-generic elmo-msgdb-create-message-entity-from-buffer (handler
 113                                                                    number
 114                                                                    &rest args)
 115   "Create message entity from current buffer.
 116 HANDLER is the message entity handler.
 117 NUMBER is the number of the newly created message entity.
 118 Rest of the ARGS is a plist of message entity field for initial value.
 119 Header region is supposed to be narrowed.")
 120
 121 ;; Transitional interface.
 122 (luna-define-generic elmo-msgdb-message-match-condition (handler
 123                                                          condition
 124                                                          entity
 125                                                          flags
 126                                                          numbers)
 127   "Return non-nil when the entity matches the condition.")
 128
 129 ;; Generic implementation.
 130 (luna-define-method elmo-msgdb-create-message-entity-from-file
 131   ((handler modb-entity-handler) number file)
 132   (let (insert-file-contents-pre-hook   ; To avoid autoconv-xmas...
 133         insert-file-contents-post-hook header-end
 134         (attrib (file-attributes file))
 135         ret-val size mtime)
 136     (with-temp-buffer
 137       (if (not (file-exists-p file))
 138           ()
 139         (setq size (nth 7 attrib))
 140         (setq mtime (timezone-make-date-arpa-standard
 141                      (current-time-string (nth 5 attrib)) (current-time-zone)))
 142         ;; insert header from file.
 143         (catch 'done
 144           (condition-case nil
 145               (elmo-msgdb-insert-file-header file)
 146             (error (throw 'done nil)))
 147           (goto-char (point-min))
 148           (setq header-end
 149                 (if (re-search-forward "\\(^--.*$\\)\\|\\(\n\n\\)" nil t)
 150                     (point)
 151                   (point-max)))
 152           (narrow-to-region (point-min) header-end)
 153           (elmo-msgdb-create-message-entity-from-buffer
 154            handler number :size size :date mtime))))))
 155
 156 (luna-define-method elmo-msgdb-make-message-entity ((handler
 157                                                      modb-entity-handler)
 158                                                     args)
 159   (cons handler args))
 160
 161 (luna-define-method elmo-msgdb-message-entity-field ((handler
 162                                                      modb-entity-handler)
 163                                                      entity field
 164                                                      &optional decode)
 165   (plist-get (cdr entity) (intern (concat ":" (symbol-name field)))))
 166
 167 (luna-define-method elmo-msgdb-message-entity-number ((handler
 168                                                        modb-entity-handler)
 169                                                       entity)
 170   (plist-get (cdr entity) :number))
 171
 172 (luna-define-method elmo-msgdb-message-entity-update-fields
 173   ((handler modb-entity-handler) entity values)
 174   (let (updated)
 175     (dolist (pair values)
 176       (unless (equal
 177                (cdr pair)
 178                (elmo-msgdb-message-entity-field handler entity (car pair)))
 179         (elmo-msgdb-message-entity-set-field handler entity
 180                                              (car pair) (cdr pair))
 181         (setq updated t)))
 182     updated))
 183
 184 ;; Legacy implementation.
 185 (eval-and-compile (luna-define-class modb-legacy-entity-handler
 186                                      (modb-entity-handler)))
 187
 188 ;;
 189 ;; mime decode cache
 190 ;;
 191 (defvar elmo-msgdb-decoded-cache-hashtb nil)
 192 (make-variable-buffer-local 'elmo-msgdb-decoded-cache-hashtb)
 193
 194 (defsubst elmo-msgdb-get-decoded-cache (string)
 195   (if elmo-use-decoded-cache
 196       (let ((hashtb (or elmo-msgdb-decoded-cache-hashtb
 197                         (setq elmo-msgdb-decoded-cache-hashtb
 198                               (elmo-make-hash 2048))))
 199             decoded)
 200         (or (elmo-get-hash-val string hashtb)
 201             (prog1
 202                 (setq decoded
 203                       (elmo-with-enable-multibyte
 204                         (decode-mime-charset-string string elmo-mime-charset)))
 205               (elmo-set-hash-val string decoded hashtb))))
 206     (elmo-with-enable-multibyte
 207       (decode-mime-charset-string string elmo-mime-charset))))
 208
 209 (defsubst modb-legacy-make-message-entity (args)
 210   "Make an message entity."
 211   (cons (plist-get args :message-id)
 212         (vector (plist-get args :number)
 213                 (plist-get args :references)
 214                 (plist-get args :from)
 215                 (plist-get args :subject)
 216                 (plist-get args :date)
 217                 (plist-get args :to)
 218                 (plist-get args :cc)
 219                 (plist-get args :size)
 220                 (plist-get args :extra))))
 221
 222 (luna-define-method elmo-msgdb-make-message-entity
 223   ((handler modb-legacy-entity-handler) args)
 224   (modb-legacy-make-message-entity args))
 225
 226 (luna-define-method elmo-msgdb-create-message-entity-from-buffer
 227   ((handler modb-legacy-entity-handler) number args)
 228   (let ((extras elmo-msgdb-extra-fields)
 229         (default-mime-charset default-mime-charset)
 230         entity message-id references from subject to cc date
 231         extra field-body charset size)
 232     (save-excursion
 233       (setq entity (modb-legacy-make-message-entity args))
 234       (set-buffer-multibyte default-enable-multibyte-characters)
 235       (setq message-id (elmo-msgdb-get-message-id-from-buffer))
 236       (and (setq charset (cdr (assoc "charset" (mime-read-Content-Type))))
 237            (setq charset (intern-soft charset))
 238            (setq default-mime-charset charset))
 239       (setq references
 240             (if elmo-msgdb-prefer-in-reply-to-for-parent
 241                 (or (elmo-msgdb-get-last-message-id
 242                      (elmo-field-body "in-reply-to"))
 243                     (elmo-msgdb-get-last-message-id
 244                      (elmo-field-body "references")))
 245               (or (elmo-msgdb-get-last-message-id
 246                    (elmo-field-body "references"))
 247                   (elmo-msgdb-get-last-message-id
 248                    (elmo-field-body "in-reply-to"))))
 249             from (elmo-replace-in-string
 250                   (elmo-mime-string (or (elmo-field-body "from")
 251                                         elmo-no-from))
 252                   "\t" " ")
 253             subject (elmo-replace-in-string
 254                      (elmo-mime-string (or (elmo-field-body "subject")
 255                                            elmo-no-subject))
 256                      "\t" " ")
 257             date (elmo-unfold-field-body "date")
 258             to   (mapconcat 'identity (elmo-multiple-field-body "to") ",")
 259             cc   (mapconcat 'identity (elmo-multiple-field-body "cc") ","))
 260       (unless (elmo-msgdb-message-entity-field handler entity 'size)
 261         (if (setq size (elmo-field-body "content-length"))
 262             (setq size (string-to-int size))
 263           (setq size 0)))
 264       (while extras
 265         (if (setq field-body (elmo-field-body (car extras)))
 266             (elmo-msgdb-message-entity-set-field
 267              handler entity (intern (downcase (car extras))) field-body))
 268         (setq extras (cdr extras)))
 269       (dolist (field '(message-id number references from subject
 270                                   date to cc size))
 271         (when (symbol-value field)
 272           (elmo-msgdb-message-entity-set-field
 273            handler entity field (symbol-value field))))
 274       entity)))
 275
 276 (luna-define-method elmo-msgdb-message-entity-number
 277   ((handler modb-legacy-entity-handler) entity)
 278   (and entity (aref (cdr entity) 0)))
 279
 280 (luna-define-method elmo-msgdb-message-entity-set-number
 281   ((handler modb-legacy-entity-handler) entity number)
 282   (and entity (aset (cdr entity) 0 number))
 283   entity)
 284
 285 (luna-define-method elmo-msgdb-message-entity-field
 286   ((handler modb-legacy-entity-handler) entity field &optional decode)
 287   (and entity
 288        (let ((field-value
 289               (case field
 290                 (to (aref (cdr entity) 5))
 291                 (cc (aref (cdr entity) 6))
 292                 (date (aref (cdr entity) 4))
 293                 (subject (aref (cdr entity) 3))
 294                 (from (aref (cdr entity) 2))
 295                 (message-id (car entity))
 296                 (references (aref (cdr entity) 1))
 297                 (size (aref (cdr entity) 7))
 298                 (t (cdr (assoc (symbol-name field) (aref (cdr entity) 8)))))))
 299          (if (and decode (memq field '(from subject)))
 300              (elmo-msgdb-get-decoded-cache field-value)
 301            field-value))))
 302
 303 (luna-define-method elmo-msgdb-message-entity-set-field
 304   ((handler modb-legacy-entity-handler) entity field value)
 305   (and entity
 306        (case field
 307          (number (aset (cdr entity) 0 value))
 308          (to (aset (cdr entity) 5 value))
 309          (cc (aset (cdr entity) 6 value))
 310          (date (aset (cdr entity) 4 value))
 311          (subject (aset (cdr entity) 3 value))
 312          (from (aset (cdr entity) 2 value))
 313          (message-id (setcar entity value))
 314          (references (aset (cdr entity) 1 value))
 315          (size (aset (cdr entity) 7 value))
 316          (t
 317           (let ((extras (and entity (aref (cdr entity) 8)))
 318                 extra)
 319             (if (setq extra (assoc (symbol-name field) extras))
 320                 (setcdr extra value)
 321               (aset (cdr entity) 8 (cons (cons (symbol-name field)
 322                                                value) extras))))))))
 323
 324 (luna-define-method elmo-msgdb-copy-message-entity
 325   ((handler modb-legacy-entity-handler) entity)
 326   (cons (car entity)
 327         (copy-sequence (cdr entity))))
 328
 329 (luna-define-method elmo-msgdb-message-match-condition
 330   ((handler modb-legacy-entity-handler) condition entity flags numbers)
 331   (cond
 332    ((vectorp condition)
 333     (elmo-msgdb-match-condition-primitive handler condition
 334                                           entity flags numbers))
 335    ((eq (car condition) 'and)
 336     (let ((lhs (elmo-msgdb-message-match-condition handler
 337                                                    (nth 1 condition)
 338                                                    entity flags numbers)))
 339       (cond
 340        ((elmo-filter-condition-p lhs)
 341         (let ((rhs (elmo-msgdb-message-match-condition
 342                     handler (nth 2 condition) entity flags numbers)))
 343           (cond ((elmo-filter-condition-p rhs)
 344                  (list 'and lhs rhs))
 345                 (rhs
 346                  lhs))))
 347        (lhs
 348         (elmo-msgdb-message-match-condition handler (nth 2 condition)
 349                                             entity flags numbers)))))
 350    ((eq (car condition) 'or)
 351     (let ((lhs (elmo-msgdb-message-match-condition handler (nth 1 condition)
 352                                                    entity flags numbers)))
 353       (cond
 354        ((elmo-filter-condition-p lhs)
 355         (let ((rhs (elmo-msgdb-message-match-condition handler
 356                                                        (nth 2 condition)
 357                                                        entity flags numbers)))
 358           (cond ((elmo-filter-condition-p rhs)
 359                  (list 'or lhs rhs))
 360                 (rhs
 361                  t)
 362                 (t
 363                  lhs))))
 364        (lhs
 365         t)
 366        (t
 367         (elmo-msgdb-message-match-condition handler
 368                                              (nth 2 condition)
 369                                              entity flags numbers)))))))
 370
 371 ;;
 372 (defun elmo-msgdb-match-condition-primitive (handler
 373                                              condition
 374                                              entity
 375                                              flags
 376                                              numbers)
 377   (catch 'unresolved
 378     (let ((key (elmo-filter-key condition))
 379           (case-fold-search t)
 380           result)
 381       (cond
 382        ((string= key "last")
 383         (setq result (<= (length (memq
 384                                   (elmo-msgdb-message-entity-number
 385                                    handler entity)
 386                                   numbers))
 387                          (string-to-int (elmo-filter-value condition)))))
 388        ((string= key "first")
 389         (setq result (< (-
 390                          (length numbers)
 391                          (length (memq
 392                                   (elmo-msgdb-message-entity-number
 393                                    handler entity)
 394                                   numbers)))
 395                         (string-to-int (elmo-filter-value condition)))))
 396        ((string= key "flag")
 397         (setq result
 398               (cond
 399                ((string= (elmo-filter-value condition) "any")
 400                 (or (memq 'important flags)
 401                     (memq 'answered flags)
 402                     (memq 'unread flags)))
 403                ((string= (elmo-filter-value condition) "digest")
 404                 (or (memq 'important flags)
 405                     (memq 'unread flags)))
 406                ((string= (elmo-filter-value condition) "unread")
 407                 (memq 'unread flags))
 408                ((string= (elmo-filter-value condition) "important")
 409                 (memq 'important flags))
 410                ((string= (elmo-filter-value condition) "answered")
 411                 (memq 'answered flags)))))
 412        ((string= key "from")
 413         (setq result (string-match
 414                       (elmo-filter-value condition)
 415                       (elmo-msgdb-message-entity-field
 416                        handler entity 'from t))))
 417        ((string= key "subject")
 418         (setq result (string-match
 419                       (elmo-filter-value condition)
 420                       (elmo-msgdb-message-entity-field
 421                        handler entity 'subject t))))
 422        ((string= key "to")
 423         (setq result (string-match
 424                       (elmo-filter-value condition)
 425                       (elmo-msgdb-message-entity-field
 426                        handler entity 'to))))
 427        ((string= key "cc")
 428         (setq result (string-match
 429                       (elmo-filter-value condition)
 430                       (elmo-msgdb-message-entity-field
 431                        handler entity 'cc))))
 432        ((or (string= key "since")
 433             (string= key "before"))
 434         (let ((field-date (elmo-date-make-sortable-string
 435                            (timezone-fix-time
 436                             (elmo-msgdb-message-entity-field
 437                              handler entity 'date)
 438                             (current-time-zone) nil)))
 439               (specified-date
 440                (elmo-date-make-sortable-string
 441                 (elmo-date-get-datevec
 442                  (elmo-filter-value condition)))))
 443           (setq result (if (string= key "since")
 444                            (or (string= specified-date field-date)
 445                                (string< specified-date field-date))
 446                          (string< field-date specified-date)))))
 447        ((member key elmo-msgdb-extra-fields)
 448         (let ((extval (elmo-msgdb-message-entity-field handler
 449                                                        entity
 450                                                        (intern key))))
 451           (when (stringp extval)
 452             (setq result (string-match
 453                           (elmo-filter-value condition)
 454                           extval)))))
 455        (t
 456         (throw 'unresolved condition)))
 457       (if (eq (elmo-filter-type condition) 'unmatch)
 458           (not result)
 459         result))))
 460
 461 (require 'product)
 462 (product-provide (provide 'modb-entity) (require 'elmo-version))
 463
 464 ;;; modb-entity.el ends here