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