elmo/elmo-mime.el

   1 ;;; elmo-mime.el --- MIME module for ELMO.
   2
   3 ;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
   4
   5 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
   6 ;; Keywords: mail, net news
   7
   8 ;; This file is part of ELMO (Elisp Library for Message Orchestration).
   9
  10 ;; This program is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14 ;;
  15 ;; This program is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19 ;;
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24 ;;
  25
  26 ;;; Commentary:
  27 ;;
  28
  29 ;;; Code:
  30 ;;
  31 (require 'elmo-vars)
  32 (require 'mmbuffer)
  33 (require 'mmimap)
  34 (require 'mime-view)
  35
  36 ;; MIME-Entity
  37 (eval-and-compile
  38   (luna-define-class elmo-mime-entity))
  39
  40 (luna-define-generic elmo-mime-entity-display-p (entity mime-mode)
  41   "Return non-nil if ENTITY is able to display with MIME-MODE.
  42
  43 MIME-MODE is a symbol which is one of the following:
  44   `mime'  (Can display each MIME part)
  45   `as-is' (Can display raw message)")
  46
  47 (luna-define-generic elmo-mime-entity-reassembled-p (entity)
  48   "Return non-nil if ENTITY is reassembled message/partial pieces.")
  49
  50 (luna-define-generic elmo-mime-entity-display (entity preview-buffer
  51                                                       &optional
  52                                                       original-major-mode
  53                                                       keymap)
  54   "Display MIME message ENTITY.
  55 PREVIEW-BUFFER is a view buffer.
  56 Optional argument ORIGINAL-MAJOR-MODE is major-mode of representation
  57 buffer of ENTITY.  If it is nil, current `major-mode' is used.
  58 If optional argument KEYMAP is specified,
  59 use for keymap of representation buffer.")
  60
  61 (luna-define-generic elmo-mime-entity-display-as-is (entity
  62                                                      preview-buffer
  63                                                      &optional
  64                                                      original-major-mode
  65                                                      keymap)
  66   "Display MIME message ENTITY as is.
  67 PREVIEW-BUFFER is a view buffer.
  68 Optional argument ORIGINAL-MAJOR-MODE is major-mode of representation
  69 buffer of ENTITY.  If it is nil, current `major-mode' is used.
  70 If optional argument KEYMAP is specified,
  71 use for keymap of representation buffer.")
  72
  73 (luna-define-method elmo-mime-entity-display ((entity elmo-mime-entity)
  74                                               preview-buffer
  75                                               &optional
  76                                               original-major-mode
  77                                               keymap)
  78   (let ((elmo-message-displaying t))
  79     (mime-display-message entity
  80                           preview-buffer
  81                           nil
  82                           keymap
  83                           original-major-mode)))
  84
  85 (defun elmo-mime-entity-fragment-p (entity)
  86   (and (not (elmo-mime-entity-reassembled-p entity))
  87        (eq (mime-entity-media-type entity) 'message)
  88        (eq (mime-entity-media-subtype entity) 'partial)))
  89
  90 (eval-and-compile
  91   (luna-define-class mime-elmo-buffer-entity (mime-buffer-entity
  92                                               elmo-mime-entity)
  93                      (reassembled))
  94   (luna-define-internal-accessors 'mime-elmo-buffer-entity)
  95   (luna-define-class mime-elmo-imap-entity (mime-imap-entity
  96                                             elmo-mime-entity)))
  97
  98 ;; Provide backend
  99 (provide 'mmelmo-imap)
 100 (provide 'mmelmo-buffer)
 101
 102 (defvar elmo-message-ignored-field-list mime-view-ignored-field-list)
 103 (defvar elmo-message-visible-field-list mime-view-visible-field-list)
 104 (defvar elmo-message-sorted-field-list nil)
 105 (defvar elmo-mime-display-header-analysis t)
 106
 107 (defcustom elmo-mime-header-max-column fill-column
 108   "*Header max column number. Default is `fill-colmn'.
 109 If a symbol of function is specified, the function is called and its return
 110 value is used."
 111   :type '(choice (integer :tag "Column Number")
 112                  (function :tag "Function"))
 113   :group 'elmo)
 114
 115 (luna-define-method initialize-instance :after ((entity mime-elmo-buffer-entity)
 116                                                 &rest init-args)
 117   entity)
 118
 119 (luna-define-method initialize-instance :around ((entity mime-elmo-imap-entity)
 120                                                  &rest init-args)
 121   (luna-call-next-method))
 122
 123 ;;; Insert sorted header.
 124 (defsubst elmo-mime-insert-header-from-buffer (buffer
 125                                                start end
 126                                                &optional invisible-fields
 127                                                visible-fields
 128                                                sort-fields)
 129   (let ((the-buf (current-buffer))
 130         (mode-obj (mime-find-field-presentation-method 'wide))
 131         field-decoder
 132         f-b p f-e field-name field field-body
 133         vf-alist (sl sort-fields))
 134     (save-excursion
 135       (set-buffer buffer)
 136       (save-restriction
 137         (narrow-to-region start end)
 138         (goto-char start)
 139         (while (re-search-forward std11-field-head-regexp nil t)
 140           (setq f-b (match-beginning 0)
 141                 p (match-end 0)
 142                 field-name (buffer-substring f-b p)
 143                 f-e (std11-field-end))
 144           (when (mime-visible-field-p field-name
 145                                       visible-fields invisible-fields)
 146             (setq field (intern
 147                          (capitalize (buffer-substring f-b (1- p))))
 148                   field-body (buffer-substring p f-e)
 149                   field-decoder
 150                   (if elmo-mime-display-header-analysis
 151                       (inline (mime-find-field-decoder-internal
 152                                field mode-obj))
 153                     (inline (lambda (x y z) x))))
 154             (setq vf-alist (append (list
 155                                     (cons field-name
 156                                           (list field-body field-decoder)))
 157                                    vf-alist))))
 158         (and vf-alist
 159              (setq vf-alist
 160                    (sort vf-alist
 161                          (function (lambda (s d)
 162                                      (let ((n 0) re
 163                                            (sf (car s))
 164                                            (df (car d)))
 165                                        (catch 'done
 166                                          (while (setq re (nth n sl))
 167                                            (setq n (1+ n))
 168                                            (and (string-match re sf)
 169                                                 (throw 'done t))
 170                                            (and (string-match re df)
 171                                                 (throw 'done nil)))
 172                                          t)))))))
 173         (with-current-buffer the-buf
 174           (while vf-alist
 175             (let* ((vf (car vf-alist))
 176                    (field-name (car vf))
 177                    (field-body (car (cdr vf)))
 178                    (field-decoder (car (cdr (cdr vf)))))
 179               (insert field-name)
 180               (insert (if field-decoder
 181                           (funcall field-decoder field-body
 182                                    (string-width field-name)
 183                                    (if (functionp elmo-mime-header-max-column)
 184                                        (funcall elmo-mime-header-max-column)
 185                                      elmo-mime-header-max-column))
 186                         ;; Don't decode
 187                         field-body))
 188               (insert "\n"))
 189             (setq vf-alist (cdr vf-alist)))
 190           (run-hooks 'mmelmo-header-inserted-hook))))))
 191
 192 (luna-define-generic elmo-mime-insert-sorted-header (entity
 193                                                      &optional invisible-fields
 194                                                      visible-fields
 195                                                      sorted-fields)
 196   "Insert sorted header fields of the ENTITY.")
 197
 198 (luna-define-method elmo-mime-insert-sorted-header ((entity
 199                                                      mime-elmo-buffer-entity)
 200                                                     &optional invisible-fields
 201                                                     visible-fields
 202                                                     sorted-fields)
 203   (elmo-mime-insert-header-from-buffer
 204    (mime-buffer-entity-buffer-internal entity)
 205    (mime-buffer-entity-header-start-internal entity)
 206    (mime-buffer-entity-header-end-internal entity)
 207    invisible-fields visible-fields sorted-fields))
 208
 209 (luna-define-method elmo-mime-insert-sorted-header ((entity
 210                                                      mime-elmo-imap-entity)
 211                                                     &optional invisible-fields
 212                                                     visible-fields
 213                                                     sorted-fields)
 214   (let ((the-buf (current-buffer))
 215         buf p-min p-max)
 216     (with-temp-buffer
 217       (insert (mime-imap-entity-header-string entity))
 218       (setq buf (current-buffer)
 219             p-min (point-min)
 220             p-max (point-max))
 221       (set-buffer the-buf)
 222       (elmo-mime-insert-header-from-buffer buf p-min p-max
 223                                            invisible-fields
 224                                            visible-fields
 225                                            sorted-fields))))
 226
 227 (luna-define-method mime-insert-text-content :around
 228   ((entity mime-elmo-buffer-entity))
 229   (luna-call-next-method)
 230   (run-hooks 'elmo-message-text-content-inserted-hook))
 231
 232 (luna-define-method mime-insert-text-content :around
 233   ((entity mime-elmo-imap-entity))
 234   (luna-call-next-method)
 235   (run-hooks 'elmo-message-text-content-inserted-hook))
 236
 237 (defun elmo-mime-insert-header (entity situation)
 238   (elmo-mime-insert-sorted-header
 239    entity
 240    elmo-message-ignored-field-list
 241    elmo-message-visible-field-list
 242    elmo-message-sorted-field-list)
 243   (run-hooks 'elmo-message-header-inserted-hook))
 244
 245 ;; mime-elmo-buffer-entity
 246 (luna-define-method elmo-mime-entity-display-p
 247   ((entity mime-elmo-buffer-entity) mime-mode)
 248   ;; always return t.
 249   t)
 250
 251 (luna-define-method elmo-mime-entity-reassembled-p ((entity
 252                                                      mime-elmo-buffer-entity))
 253   (mime-elmo-buffer-entity-reassembled-internal entity))
 254
 255 (luna-define-method elmo-mime-entity-display-as-is ((entity
 256                                                      mime-elmo-buffer-entity)
 257                                                      preview-buffer
 258                                                      &optional
 259                                                      original-major-mode
 260                                                      keymap)
 261   (elmo-mime-display-as-is-internal entity
 262                                     preview-buffer
 263                                     nil
 264                                     keymap
 265                                     original-major-mode))
 266
 267 ;; mime-elmo-imap-entity
 268 (luna-define-method elmo-mime-entity-display-p
 269   ((entity mime-elmo-imap-entity) mime-mode)
 270   (not (eq mime-mode 'as-is)))
 271
 272 (luna-define-method elmo-mime-entity-display-as-is ((entity
 273                                                      mime-elmo-imap-entity)
 274                                                      preview-buffer
 275                                                      &optional
 276                                                      original-major-mode
 277                                                      keymap)
 278   (error "Does not support this method"))
 279
 280
 281 (defun elmo-message-mime-entity (folder number rawbuf reassemble
 282                                         &optional
 283                                         ignore-cache unread entire)
 284   "Return the mime-entity structure of the message in the FOLDER with NUMBER.
 285 RAWBUF is the output buffer for original message.
 286 If REASSEMBLE is non-nil and MIME media type of the message is message/partial,
 287 the mime-entity is reassembled partial message.
 288 If optional argument IGNORE-CACHE is non-nil, existing cache is ignored.
 289 If second optional argument UNREAD is non-nil,
 290 keep status of the message as unread.
 291 If third optional argument ENTIRE is non-nil, fetch entire message at once."
 292   (let (id message entity content-type)
 293     (or (and reassemble
 294              (setq entity (elmo-message-entity folder number))
 295              (setq id (if (setq content-type (elmo-message-entity-field
 296                                               entity 'content-type))
 297                           (and (string-match "message/partial" content-type)
 298                                (mime-content-type-parameter
 299                                 (mime-parse-Content-Type content-type) "id"))
 300                         (and (setq message (elmo-message-mime-entity-internal
 301                                             folder number rawbuf
 302                                             ignore-cache unread entire))
 303                              (eq (mime-entity-media-type message) 'message)
 304                              (eq (mime-entity-media-subtype message) 'partial)
 305                              (mime-content-type-parameter
 306                               (mime-entity-content-type message) "id"))))
 307              (elmo-message-reassembled-mime-entity
 308               folder id rawbuf
 309               (elmo-message-entity-field entity 'subject 'decode)
 310               ignore-cache
 311               unread))
 312         message
 313         (elmo-message-mime-entity-internal
 314          folder number rawbuf ignore-cache unread entire))))
 315
 316
 317 (defun elmo-message-mime-entity-internal (folder number rawbuf
 318                                                  &optional
 319                                                  ignore-cache unread entire)
 320   (let ((strategy (elmo-find-fetch-strategy folder number
 321                                             ignore-cache
 322                                             entire)))
 323     (cond ((null strategy) nil)
 324           ((eq (elmo-fetch-strategy-entireness strategy) 'section)
 325            (mime-open-entity
 326             'elmo-imap
 327             (luna-make-entity 'mime-elmo-imap-location
 328                               :folder folder
 329                               :number number
 330                               :rawbuf rawbuf
 331                               :strategy strategy)))
 332           (t
 333            (with-current-buffer rawbuf
 334              (let (buffer-read-only)
 335                (erase-buffer)
 336                (elmo-message-fetch folder number strategy unread)))
 337            (mime-open-entity 'elmo-buffer rawbuf)))))
 338
 339
 340 (defconst elmo-mime-inherit-field-list-from-enclosed
 341   '("^Content-.*:" "^Message-Id:" "^Subject:"
 342     "^Encrypted.*:" "^MIME-Version:"))
 343
 344 (defsubst elmo-mime-make-reassembled-mime-entity (buffer)
 345   (let ((entity (mime-open-entity 'elmo-buffer buffer)))
 346     (mime-elmo-buffer-entity-set-reassembled-internal entity t)
 347     entity))
 348
 349 (defun elmo-message-reassembled-mime-entity (folder id rawbuf subject
 350                                                     &optional
 351                                                     ignore-cache
 352                                                     unread)
 353   (let ((cache (elmo-file-cache-get (concat "<" id ">")))
 354         pieces)
 355     (if (and (not ignore-cache)
 356              (eq (elmo-file-cache-status cache) 'entire))
 357         ;; use cache
 358         (with-current-buffer rawbuf
 359           (let (buffer-read-only)
 360             (erase-buffer)
 361             (elmo-file-cache-load (elmo-file-cache-path cache) nil))
 362           (elmo-mime-make-reassembled-mime-entity rawbuf))
 363       ;; reassemble fragment of the entity
 364       (when (setq pieces (elmo-mime-collect-message/partial-pieces
 365                           folder id
 366                           (regexp-quote
 367                            (if (string-match "[0-9\n]+" subject)
 368                                (substring subject 0 (match-beginning 0))
 369                              subject))
 370                           ignore-cache unread))
 371         (with-current-buffer rawbuf
 372           (let (buffer-read-only
 373                 (outer-header (car pieces))
 374                 (pieces (sort (cdr pieces) (lambda (l r) (< (car l) (car r)))))
 375                 contents entity)
 376             (erase-buffer)
 377             (while pieces
 378               (insert (cdr (car pieces)))
 379               (setq pieces (cdr pieces)))
 380             (let ((case-fold-search t))
 381               (save-restriction
 382                 (std11-narrow-to-header)
 383                 (goto-char (point-min))
 384                 (while (re-search-forward std11-field-head-regexp nil t)
 385                   (let ((field-start (match-beginning 0)))
 386                     (unless (mime-visible-field-p
 387                              (buffer-substring field-start (match-end 0))
 388                              elmo-mime-inherit-field-list-from-enclosed
 389                              '(".*"))
 390                       (delete-region field-start (1+ (std11-field-end))))))))
 391             (goto-char (point-min))
 392             (insert outer-header)
 393             ;; save cache
 394             (elmo-file-cache-save (elmo-file-cache-path cache) nil)
 395             (elmo-mime-make-reassembled-mime-entity rawbuf)))))))
 396
 397 (defun elmo-mime-collect-message/partial-pieces (folder id subject-regexp
 398                                                         &optional
 399                                                         ignore-cache
 400                                                         unread)
 401   (catch 'complete
 402     (with-temp-buffer
 403       (set-buffer-multibyte nil)
 404       (let (total header pieces)
 405         (elmo-folder-do-each-message-entity (entity folder)
 406           (when (string-match
 407                  subject-regexp
 408                  (elmo-message-entity-field entity 'subject 'decode))
 409             (erase-buffer)
 410             (let* ((message (elmo-message-mime-entity-internal
 411                              folder
 412                              (elmo-message-entity-number entity)
 413                              (current-buffer)
 414                              ignore-cache
 415                              unread))
 416                    (ct (mime-entity-content-type message))
 417                    (the-id (or (mime-content-type-parameter ct "id") ""))
 418                    number)
 419               (when (string= (downcase the-id)
 420                              (downcase id))
 421                 (setq number (string-to-number
 422                               (mime-content-type-parameter ct "number")))
 423                 (setq pieces (cons (cons number (mime-entity-body message))
 424                                    pieces))
 425                 (when (= number 1)
 426                   (let ((case-fold-search t))
 427                     (save-restriction
 428                       (std11-narrow-to-header)
 429                       (goto-char (point-min))
 430                       (while (re-search-forward std11-field-head-regexp nil t)
 431                         (let ((field-start (match-beginning 0)))
 432                           (when (mime-visible-field-p
 433                                  (buffer-substring field-start (match-end 0))
 434                                  nil
 435                                  elmo-mime-inherit-field-list-from-enclosed)
 436                             (setq header (concat
 437                                           header
 438                                           (buffer-substring
 439                                            field-start (std11-field-end))
 440                                           "\n"))))))))
 441                 (unless total
 442                   (setq total (ignore-errors
 443                                 (string-to-number
 444                                  (mime-content-type-parameter ct "total")))))
 445                 (when (and total
 446                            (> total 0)
 447                            (>= (length pieces) total))
 448                   (throw 'complete (cons header pieces)))))))))
 449     ;; return value
 450     nil))
 451
 452
 453 ;; Replacement of mime-display-message.
 454 (defun elmo-mime-display-as-is-internal (message
 455                                          &optional preview-buffer
 456                                          mother default-keymap-or-function
 457                                          original-major-mode keymap)
 458   (mime-maybe-hide-echo-buffer)
 459   (let ((win-conf (current-window-configuration)))
 460     (or preview-buffer
 461         (setq preview-buffer
 462               (concat "*Preview-" (mime-entity-name message) "*")))
 463     (or original-major-mode
 464         (setq original-major-mode major-mode))
 465     (let ((inhibit-read-only t))
 466       (set-buffer (get-buffer-create preview-buffer))
 467       (widen)
 468       (erase-buffer)
 469       (if mother
 470           (setq mime-mother-buffer mother))
 471       (setq mime-preview-original-window-configuration win-conf)
 472       (setq major-mode 'mime-view-mode)
 473       (setq mode-name "MIME-View")
 474
 475       ;; Humm...
 476       (set-buffer-multibyte nil)
 477       (insert (mime-entity-body message))
 478       (set-buffer-multibyte t)
 479       (decode-coding-region (point-min) (point-max)
 480                             elmo-mime-display-as-is-coding-system)
 481       (goto-char (point-min))
 482       (insert "\n")
 483       (goto-char (point-min))
 484
 485       (let ((method (cdr (assq original-major-mode
 486                                mime-header-presentation-method-alist))))
 487         (if (functionp method)
 488             (funcall method message nil)))
 489
 490       ;; set original major mode for mime-preview-quit
 491       (put-text-property (point-min) (point-max)
 492                          'mime-view-situation
 493                          `((major-mode . ,original-major-mode)))
 494       (put-text-property (point-min) (point-max)
 495                          'elmo-as-is-entity message)
 496       (use-local-map
 497        (or keymap
 498            (if default-keymap-or-function
 499                (mime-view-define-keymap default-keymap-or-function)
 500              mime-view-mode-default-map)))
 501       (goto-char (point-min))
 502       (search-forward "\n\n" nil t)
 503       (run-hooks 'mime-view-mode-hook)
 504       (set-buffer-modified-p nil)
 505       (setq buffer-read-only t)
 506       preview-buffer)))
 507
 508 (require 'product)
 509 (product-provide (provide 'elmo-mime) (require 'elmo-version))
 510
 511 ;; elmo-mime.el ends here