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-display (entity preview-buffer
  48                                                       &optional
  49                                                       original-major-mode
  50                                                       keymap)
  51   "Display MIME message ENTITY.
  52 PREVIEW-BUFFER is a view buffer.
  53 Optional argument ORIGINAL-MAJOR-MODE is major-mode of representation
  54 buffer of ENTITY.  If it is nil, current `major-mode' is used.
  55 If optional argument KEYMAP is specified,
  56 use for keymap of representation buffer.")
  57
  58 (luna-define-generic elmo-mime-entity-display-as-is (entity
  59                                                      preview-buffer
  60                                                      &optional
  61                                                      original-major-mode
  62                                                      keymap)
  63   "Display MIME message ENTITY as is.
  64 PREVIEW-BUFFER is a view buffer.
  65 Optional argument ORIGINAL-MAJOR-MODE is major-mode of representation
  66 buffer of ENTITY.  If it is nil, current `major-mode' is used.
  67 If optional argument KEYMAP is specified,
  68 use for keymap of representation buffer.")
  69
  70 (luna-define-method elmo-mime-entity-display ((entity elmo-mime-entity)
  71                                               preview-buffer
  72                                               &optional
  73                                               original-major-mode
  74                                               keymap)
  75   (mime-display-message entity
  76                         preview-buffer
  77                         nil
  78                         keymap
  79                         original-major-mode))
  80
  81
  82 (eval-and-compile
  83   (luna-define-class mime-elmo-buffer-entity (mime-buffer-entity
  84                                               elmo-mime-entity))
  85   (luna-define-class mime-elmo-imap-entity (mime-imap-entity
  86                                             elmo-mime-entity)))
  87
  88 ;; Provide backend
  89 (provide 'mmelmo-imap)
  90 (provide 'mmelmo-buffer)
  91
  92 (defvar elmo-message-ignored-field-list mime-view-ignored-field-list)
  93 (defvar elmo-message-visible-field-list mime-view-visible-field-list)
  94 (defvar elmo-message-sorted-field-list nil)
  95 (defvar elmo-mime-display-header-analysis t)
  96
  97 (defcustom elmo-mime-header-max-column fill-column
  98   "*Header max column number. Default is `fill-colmn'.
  99 If a symbol of function is specified, the function is called and its return
 100 value is used."
 101   :type '(choice (integer :tag "Column Number")
 102                  (function :tag "Function"))
 103   :group 'elmo)
 104
 105 (luna-define-method initialize-instance :after ((entity mime-elmo-buffer-entity)
 106                                                 &rest init-args)
 107   entity)
 108
 109 (luna-define-method initialize-instance :around ((entity mime-elmo-imap-entity)
 110                                                  &rest init-args)
 111   (luna-call-next-method))
 112
 113 ;;; Insert sorted header.
 114 (defsubst elmo-mime-insert-header-from-buffer (buffer
 115                                                start end
 116                                                &optional invisible-fields
 117                                                visible-fields
 118                                                sort-fields)
 119   (let ((the-buf (current-buffer))
 120         (mode-obj (mime-find-field-presentation-method 'wide))
 121         field-decoder
 122         f-b p f-e field-name field field-body
 123         vf-alist (sl sort-fields))
 124     (save-excursion
 125       (set-buffer buffer)
 126       (save-restriction
 127         (narrow-to-region start end)
 128         (goto-char start)
 129         (while (re-search-forward std11-field-head-regexp nil t)
 130           (setq f-b (match-beginning 0)
 131                 p (match-end 0)
 132                 field-name (buffer-substring f-b p)
 133                 f-e (std11-field-end))
 134           (when (mime-visible-field-p field-name
 135                                       visible-fields invisible-fields)
 136             (setq field (intern
 137                          (capitalize (buffer-substring f-b (1- p))))
 138                   field-body (buffer-substring p f-e)
 139                   field-decoder
 140                   (if elmo-mime-display-header-analysis
 141                       (inline (mime-find-field-decoder-internal
 142                                field mode-obj))
 143                     (inline (lambda (x y z) x))))
 144             (setq vf-alist (append (list
 145                                     (cons field-name
 146                                           (list field-body field-decoder)))
 147                                    vf-alist))))
 148         (and vf-alist
 149              (setq vf-alist
 150                    (sort vf-alist
 151                          (function (lambda (s d)
 152                                      (let ((n 0) re
 153                                            (sf (car s))
 154                                            (df (car d)))
 155                                        (catch 'done
 156                                          (while (setq re (nth n sl))
 157                                            (setq n (1+ n))
 158                                            (and (string-match re sf)
 159                                                 (throw 'done t))
 160                                            (and (string-match re df)
 161                                                 (throw 'done nil)))
 162                                          t)))))))
 163         (with-current-buffer the-buf
 164           (while vf-alist
 165             (let* ((vf (car vf-alist))
 166                    (field-name (car vf))
 167                    (field-body (car (cdr vf)))
 168                    (field-decoder (car (cdr (cdr vf)))))
 169               (insert field-name)
 170               (insert (if field-decoder
 171                           (funcall field-decoder field-body
 172                                    (string-width field-name)
 173                                    (if (functionp elmo-mime-header-max-column)
 174                                        (funcall elmo-mime-header-max-column)
 175                                      elmo-mime-header-max-column))
 176                         ;; Don't decode
 177                         field-body))
 178               (insert "\n"))
 179             (setq vf-alist (cdr vf-alist)))
 180           (run-hooks 'mmelmo-header-inserted-hook))))))
 181
 182 (luna-define-generic elmo-mime-insert-sorted-header (entity
 183                                                      &optional invisible-fields
 184                                                      visible-fields
 185                                                      sorted-fields)
 186   "Insert sorted header fields of the ENTITY.")
 187
 188 (luna-define-method elmo-mime-insert-sorted-header ((entity
 189                                                      mime-elmo-buffer-entity)
 190                                                     &optional invisible-fields
 191                                                     visible-fields
 192                                                     sorted-fields)
 193   (elmo-mime-insert-header-from-buffer
 194    (mime-buffer-entity-buffer-internal entity)
 195    (mime-buffer-entity-header-start-internal entity)
 196    (mime-buffer-entity-header-end-internal entity)
 197    invisible-fields visible-fields sorted-fields))
 198
 199 (luna-define-method elmo-mime-insert-sorted-header ((entity
 200                                                      mime-elmo-imap-entity)
 201                                                     &optional invisible-fields
 202                                                     visible-fields
 203                                                     sorted-fields)
 204   (let ((the-buf (current-buffer))
 205         buf p-min p-max)
 206     (with-temp-buffer
 207       (insert (mime-imap-entity-header-string entity))
 208       (setq buf (current-buffer)
 209             p-min (point-min)
 210             p-max (point-max))
 211       (set-buffer the-buf)
 212       (elmo-mime-insert-header-from-buffer buf p-min p-max
 213                                            invisible-fields
 214                                            visible-fields
 215                                            sorted-fields))))
 216
 217 (luna-define-method mime-insert-text-content :around
 218   ((entity mime-elmo-buffer-entity))
 219   (luna-call-next-method)
 220   (run-hooks 'elmo-message-text-content-inserted-hook))
 221
 222 (luna-define-method mime-insert-text-content :around
 223   ((entity mime-elmo-imap-entity))
 224   (luna-call-next-method)
 225   (run-hooks 'elmo-message-text-content-inserted-hook))
 226
 227 (defun elmo-mime-insert-header (entity situation)
 228   (elmo-mime-insert-sorted-header
 229    entity
 230    elmo-message-ignored-field-list
 231    elmo-message-visible-field-list
 232    elmo-message-sorted-field-list)
 233   (run-hooks 'elmo-message-header-inserted-hook))
 234
 235 ;; mime-elmo-buffer-entity
 236 (luna-define-method elmo-mime-entity-display-p
 237   ((entity mime-elmo-buffer-entity) mime-mode)
 238   ;; always return t.
 239   t)
 240
 241 (luna-define-method elmo-mime-entity-display-as-is ((entity
 242                                                      mime-elmo-buffer-entity)
 243                                                      preview-buffer
 244                                                      &optional
 245                                                      original-major-mode
 246                                                      keymap)
 247   (elmo-mime-display-as-is-internal entity
 248                                     preview-buffer
 249                                     nil
 250                                     keymap
 251                                     original-major-mode))
 252
 253 ;; mime-elmo-imap-entity
 254 (luna-define-method elmo-mime-entity-display-p
 255   ((entity mime-elmo-imap-entity) mime-mode)
 256   (not (eq mime-mode 'as-is)))
 257
 258 (luna-define-method elmo-mime-entity-display-as-is ((entity
 259                                                      mime-elmo-imap-entity)
 260                                                      preview-buffer
 261                                                      &optional
 262                                                      original-major-mode
 263                                                      keymap)
 264   (error "Don't support this method."))
 265
 266
 267 (defun elmo-message-mime-entity (folder number rawbuf
 268                                         &optional
 269                                         ignore-cache unread entire)
 270   "Return the mime-entity structure of the message in the FOLDER with NUMBER.
 271 RAWBUF is the output buffer for original message.
 272 If optional argument IGNORE-CACHE is non-nil, existing cache is ignored.
 273 If second optional argument UNREAD is non-nil,
 274 keep status of the message as unread.
 275 If third optional argument ENTIRE is non-nil, fetch entire message at once."
 276   (let ((strategy (elmo-find-fetch-strategy folder number
 277                                             ignore-cache
 278                                             entire)))
 279     (cond ((null strategy) nil)
 280           ((eq (elmo-fetch-strategy-entireness strategy) 'section)
 281            (mime-open-entity
 282             'elmo-imap
 283             (luna-make-entity 'mime-elmo-imap-location
 284                               :folder folder
 285                               :number number
 286                               :rawbuf rawbuf
 287                               :strategy strategy)))
 288           (t
 289            (with-current-buffer rawbuf
 290              (let (buffer-read-only)
 291                (erase-buffer)
 292                (elmo-message-fetch folder number strategy
 293                                    nil (current-buffer)
 294                                    unread)))
 295            (mime-open-entity 'elmo-buffer rawbuf)))))
 296
 297 ;; Replacement of mime-display-message.
 298 (defun elmo-mime-display-as-is-internal (message
 299                                          &optional preview-buffer
 300                                          mother default-keymap-or-function
 301                                          original-major-mode keymap)
 302   (mime-maybe-hide-echo-buffer)
 303   (let ((win-conf (current-window-configuration)))
 304     (or preview-buffer
 305         (setq preview-buffer
 306               (concat "*Preview-" (mime-entity-name message) "*")))
 307     (or original-major-mode
 308         (setq original-major-mode major-mode))
 309     (let ((inhibit-read-only t))
 310       (set-buffer (get-buffer-create preview-buffer))
 311       (widen)
 312       (erase-buffer)
 313       (if mother
 314           (setq mime-mother-buffer mother))
 315       (setq mime-preview-original-window-configuration win-conf)
 316       (setq major-mode 'mime-view-mode)
 317       (setq mode-name "MIME-View")
 318
 319       ;; Humm...
 320       (set-buffer-multibyte nil)
 321       (insert (mime-entity-body message))
 322       (set-buffer-multibyte t)
 323       (decode-coding-region (point-min) (point-max)
 324                             elmo-mime-display-as-is-coding-system)
 325       (goto-char (point-min))
 326       (insert "\n")
 327       (goto-char (point-min))
 328
 329       (let ((method (cdr (assq original-major-mode
 330                                mime-header-presentation-method-alist))))
 331         (if (functionp method)
 332             (funcall method message nil)))
 333
 334       ;; set original major mode for mime-preview-quit
 335       (put-text-property (point-min) (point-max)
 336                          'mime-view-situation
 337                          `((major-mode . ,original-major-mode)))
 338       (put-text-property (point-min) (point-max)
 339                          'elmo-as-is-entity message)
 340       (use-local-map
 341        (or keymap
 342            (if default-keymap-or-function
 343                (mime-view-define-keymap default-keymap-or-function)
 344              mime-view-mode-default-map)))
 345       (goto-char (point-min))
 346       (search-forward "\n\n" nil t)
 347       (run-hooks 'mime-view-mode-hook)
 348       (set-buffer-modified-p nil)
 349       (setq buffer-read-only t)
 350       preview-buffer)))
 351
 352 (require 'product)
 353 (product-provide (provide 'elmo-mime) (require 'elmo-version))
 354
 355 ;; elmo-mime.el ends here