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