X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=elmo%2Felmo-mime.el;h=6beaea92b08d5851c8225c86c46bab65a03ab543;hb=f662cbd30adfa2363aadd8978c9730b0307bae6c;hp=baa2eb0f39c2980d010f486bab583a5b2041c1f8;hpb=0a4f27eec0a2e5035d6bb853a62dd7631ea8cb2a;p=elisp%2Fwanderlust.git diff --git a/elmo/elmo-mime.el b/elmo/elmo-mime.el index baa2eb0..6beaea9 100644 --- a/elmo/elmo-mime.el +++ b/elmo/elmo-mime.el @@ -33,9 +33,73 @@ (require 'mmimap) (require 'mime-view) +(eval-when-compile + (require 'luna) + (require 'elmo) ; elmo-folder-do-each-message-entity + (require 'cl)) + +;; MIME-Entity +(eval-and-compile + (luna-define-class elmo-mime-entity)) + +(luna-define-generic elmo-mime-entity-display-p (entity mime-mode) + "Return non-nil if ENTITY is able to display with MIME-MODE. + +MIME-MODE is a symbol which is one of the following: + `mime' (Can display each MIME part) + `as-is' (Can display raw message)") + +(luna-define-generic elmo-mime-entity-reassembled-p (entity) + "Return non-nil if ENTITY is reassembled message/partial pieces.") + +(luna-define-generic elmo-mime-entity-display (entity preview-buffer + &optional + original-major-mode + keymap) + "Display MIME message ENTITY. +PREVIEW-BUFFER is a view buffer. +Optional argument ORIGINAL-MAJOR-MODE is major-mode of representation +buffer of ENTITY. If it is nil, current `major-mode' is used. +If optional argument KEYMAP is specified, +use for keymap of representation buffer.") + +(luna-define-generic elmo-mime-entity-display-as-is (entity + preview-buffer + &optional + original-major-mode + keymap) + "Display MIME message ENTITY as is. +PREVIEW-BUFFER is a view buffer. +Optional argument ORIGINAL-MAJOR-MODE is major-mode of representation +buffer of ENTITY. If it is nil, current `major-mode' is used. +If optional argument KEYMAP is specified, +use for keymap of representation buffer.") + +(luna-define-method elmo-mime-entity-display ((entity elmo-mime-entity) + preview-buffer + &optional + original-major-mode + keymap) + (let ((elmo-message-displaying t) + (default-mime-charset 'x-unknown)) + (mime-display-message entity + preview-buffer + nil + keymap + original-major-mode))) + +(defun elmo-mime-entity-fragment-p (entity) + (and (not (elmo-mime-entity-reassembled-p entity)) + (eq (mime-entity-media-type entity) 'message) + (eq (mime-entity-media-subtype entity) 'partial))) + (eval-and-compile - (luna-define-class mime-elmo-buffer-entity (mime-buffer-entity) ()) - (luna-define-class mime-elmo-imap-entity (mime-imap-entity) ())) + (luna-define-class mime-elmo-buffer-entity (mime-buffer-entity + elmo-mime-entity) + (reassembled)) + (luna-define-internal-accessors 'mime-elmo-buffer-entity) + (luna-define-class mime-elmo-imap-entity (mime-imap-entity + elmo-mime-entity))) ;; Provide backend (provide 'mmelmo-imap) @@ -44,21 +108,18 @@ (defvar elmo-message-ignored-field-list mime-view-ignored-field-list) (defvar elmo-message-visible-field-list mime-view-visible-field-list) (defvar elmo-message-sorted-field-list nil) +(defvar elmo-mime-display-header-analysis t) -(defcustom elmo-mime-header-max-column fill-column +(defcustom elmo-mime-header-max-column 'fill-column "*Header max column number. Default is `fill-colmn'. +If a symbol of variable is specified, use its value in message buffer. If a symbol of function is specified, the function is called and its return value is used." :type '(choice (integer :tag "Column Number") + (variable :tag "Variable") (function :tag "Function")) :group 'elmo) -(defcustom elmo-mime-display-as-is-coding-system (if (boundp 'MULE) - '*autoconv* 'undecided) - "*Coding system used when message is displayed as is." - :type 'symbol - :group 'elmo) - (luna-define-method initialize-instance :after ((entity mime-elmo-buffer-entity) &rest init-args) entity) @@ -74,64 +135,64 @@ value is used." visible-fields sort-fields) (let ((the-buf (current-buffer)) - (mode-obj (mime-find-field-presentation-method 'wide)) - field-decoder - f-b p f-e field-name field field-body - vf-alist (sl sort-fields)) - (save-excursion - (set-buffer buffer) + (max-column (cond ((functionp elmo-mime-header-max-column) + (funcall elmo-mime-header-max-column)) + ((and (symbolp elmo-mime-header-max-column) + (boundp elmo-mime-header-max-column)) + (symbol-value elmo-mime-header-max-column)) + (t + elmo-mime-header-max-column))) + vf-alist) + (with-current-buffer buffer (save-restriction (narrow-to-region start end) (goto-char start) (while (re-search-forward std11-field-head-regexp nil t) - (setq f-b (match-beginning 0) - p (match-end 0) - field-name (buffer-substring f-b p) - f-e (std11-field-end)) - (when (mime-visible-field-p field-name - visible-fields invisible-fields) - (setq field (intern - (capitalize (buffer-substring f-b (1- p)))) - field-body (buffer-substring p f-e) - field-decoder (inline (mime-find-field-decoder-internal - field mode-obj))) - (setq vf-alist (append (list - (cons field-name - (list field-body field-decoder))) - vf-alist)))) - (and vf-alist - (setq vf-alist - (sort vf-alist - (function (lambda (s d) - (let ((n 0) re - (sf (car s)) - (df (car d))) - (catch 'done - (while (setq re (nth n sl)) - (setq n (1+ n)) - (and (string-match re sf) - (throw 'done t)) - (and (string-match re df) - (throw 'done nil))) - t))))))) - (with-current-buffer the-buf - (while vf-alist - (let* ((vf (car vf-alist)) - (field-name (car vf)) - (field-body (car (cdr vf))) - (field-decoder (car (cdr (cdr vf))))) - (insert field-name) - (insert (if field-decoder - (funcall field-decoder field-body - (string-width field-name) - (if (functionp elmo-mime-header-max-column) - (funcall elmo-mime-header-max-column) - elmo-mime-header-max-column)) - ;; Don't decode - field-body)) - (insert "\n")) - (setq vf-alist (cdr vf-alist))) - (run-hooks 'mmelmo-header-inserted-hook)))))) + (let* ((field-start (match-beginning 0)) + (name-end (match-end 0)) + (field-name (buffer-substring field-start name-end))) + (when (mime-visible-field-p field-name + visible-fields invisible-fields) + (let* ((field (intern + (capitalize + (buffer-substring field-start (1- name-end))))) + (field-body (buffer-substring name-end (std11-field-end))) + (field-decoder + (and elmo-mime-display-header-analysis + (inline (mime-find-field-decoder field 'wide))))) + (setq vf-alist (cons (list field-name field-body field-decoder) + vf-alist))))))) + (and vf-alist + (setq vf-alist + (sort vf-alist + (lambda (s d) + (let ((sf (car s)) + (df (car d))) + (catch 'done + (dolist (re sort-fields) + (when (string-match re sf) + (throw 'done t)) + (when (string-match re df) + (throw 'done nil))) + t))))))) + (set-buffer the-buf) ; verbose. remove me. + (save-excursion + (while vf-alist + (let* ((vf (car vf-alist)) + (field-name (nth 0 vf)) + (field-body (nth 1 vf)) + (field-decoder (nth 2 vf))) + (insert field-name) + (insert (or (and field-decoder + (ignore-errors + (funcall field-decoder field-body + (string-width field-name) + max-column))) + ;; Don't decode + field-body)) + (insert "\n")) + (setq vf-alist (cdr vf-alist))) + (run-hooks 'mmelmo-header-inserted-hook)))) (luna-define-generic elmo-mime-insert-sorted-header (entity &optional invisible-fields @@ -186,94 +247,213 @@ value is used." elmo-message-sorted-field-list) (run-hooks 'elmo-message-header-inserted-hook)) -(defun elmo-make-mime-message-location (folder number strategy rawbuf unread) -;; Return the MIME message location structure. -;; FOLDER is the ELMO folder structure. -;; NUMBER is the number of the message in the FOLDER. -;; STRATEGY is the message fetching strategy. -;; RAWBUF is the output buffer for original message. -;; If second optional argument UNREAD is non-nil, message is not marked -;; as read. - (if (and strategy - (eq (elmo-fetch-strategy-entireness strategy) 'section)) - (luna-make-entity - 'mime-elmo-imap-location - :folder folder - :number number - :rawbuf rawbuf - :strategy strategy) - (with-current-buffer rawbuf - (let (buffer-read-only) - (erase-buffer) - (if strategy - (elmo-message-fetch folder number strategy - nil (current-buffer) - unread)))) - rawbuf)) - -(defun elmo-mime-message-display (folder number viewbuf rawbuf original-mode - &optional ignore-cache unread keymap) - "Display MIME message. -A message in the FOLDER with NUMBER is displayed on the VIEWBUF using RAWBUF. -VIEWBUF is a view buffer and RAWBUF is a raw buffer. -ORIGINAL is the major mode of RAWBUF. -If optional argument IGNORE-CACHE is specified, existing cache is ignored. -If second optional argument UNREAD is specified, message is displayed but -keep it as unread. -Return non-nil if not entire message was fetched." - (let (mime-display-header-hook ; Do nothing. - (elmo-message-displaying t) - entity strategy) - (unless (zerop (elmo-folder-length folder)) - (setq entity (elmo-message-entity folder number))) - (setq strategy (if entity (elmo-find-fetch-strategy folder entity - ignore-cache) - (elmo-make-fetch-strategy 'entire))) - (mime-display-message - (mime-open-entity - (if (and strategy - (eq (elmo-fetch-strategy-entireness strategy) 'section)) - 'elmo-imap - 'elmo-buffer) - (elmo-make-mime-message-location - folder number strategy rawbuf unread)) - viewbuf nil keymap - original-mode) - (if strategy - (or (elmo-fetch-strategy-use-cache strategy) - (eq (elmo-fetch-strategy-entireness strategy) - 'section))))) - -(defun elmo-mime-display-as-is (folder number viewbuf rawbuf original-mode - &optional ignore-cache unread keymap) - "Display MIME message. -A message in the FOLDER with NUMBER is displayed on the VIEWBUF using RAWBUF. -VIEWBUF is a view buffer and RAWBUF is a raw buffer. -ORIGINAL is the major mode of RAWBUF. -If optional argument IGNORE-CACHE is specified, existing cache is ignored. -If second optional argument UNREAD is specified, message is displayed but -keep it as unread. -Return non-nil if cache is used." - (let ((entity (elmo-msgdb-message-entity (elmo-folder-msgdb folder) number)) - mime-display-header-hook ; Do nothing. - cache-file strategy use-cache) - (when entity - (setq cache-file (elmo-file-cache-get - (elmo-message-entity-field entity 'message-id))) - (setq use-cache (and (elmo-message-use-cache-p folder number) - (eq (elmo-file-cache-status cache-file) 'entire)))) - (setq strategy (elmo-make-fetch-strategy - 'entire use-cache - (elmo-message-use-cache-p folder number) - (elmo-file-cache-path cache-file))) - (elmo-mime-display-as-is-internal - (mime-open-entity - 'elmo-buffer - (elmo-make-mime-message-location - folder number strategy rawbuf unread)) - viewbuf nil keymap original-mode) - (when strategy - (elmo-fetch-strategy-use-cache strategy)))) +;; mime-elmo-buffer-entity +(luna-define-method elmo-mime-entity-display-p + ((entity mime-elmo-buffer-entity) mime-mode) + ;; always return t. + t) + +(luna-define-method elmo-mime-entity-reassembled-p ((entity + mime-elmo-buffer-entity)) + (mime-elmo-buffer-entity-reassembled-internal entity)) + +(luna-define-method elmo-mime-entity-display-as-is ((entity + mime-elmo-buffer-entity) + preview-buffer + &optional + original-major-mode + keymap) + (elmo-mime-display-as-is-internal entity + preview-buffer + nil + keymap + original-major-mode)) + +;; mime-elmo-imap-entity +(luna-define-method elmo-mime-entity-display-p + ((entity mime-elmo-imap-entity) mime-mode) + (not (eq mime-mode 'as-is))) + +(luna-define-method elmo-mime-entity-display-as-is ((entity + mime-elmo-imap-entity) + preview-buffer + &optional + original-major-mode + keymap) + (error "Does not support this method")) + + +(defun elmo-message-mime-entity (folder number rawbuf reassemble + &optional + ignore-cache unread entire) + "Return the mime-entity structure of the message in the FOLDER with NUMBER. +RAWBUF is the output buffer for original message. +If REASSEMBLE is non-nil and MIME media type of the message is message/partial, +the mime-entity is reassembled partial message. +If optional argument IGNORE-CACHE is non-nil, existing cache is ignored. +If second optional argument UNREAD is non-nil, +keep status of the message as unread. +If third optional argument ENTIRE is non-nil, fetch entire message at once." + (let (id message entity content-type) + (or (and reassemble + (setq entity (elmo-message-entity folder number)) + (setq id (if (setq content-type (elmo-message-entity-field + entity 'content-type)) + (and (string-match "message/partial" content-type) + (mime-content-type-parameter + (mime-parse-Content-Type content-type) "id")) + (and (setq message (elmo-message-mime-entity-internal + folder number rawbuf + ignore-cache unread entire)) + (eq (mime-entity-media-type message) 'message) + (eq (mime-entity-media-subtype message) 'partial) + (mime-content-type-parameter + (mime-entity-content-type message) "id")))) + (elmo-message-reassembled-mime-entity + folder id rawbuf + (elmo-message-entity-field entity 'subject) + ignore-cache + unread)) + message + (elmo-message-mime-entity-internal + folder number rawbuf ignore-cache unread entire)))) + + +(defun elmo-message-mime-entity-internal (folder number rawbuf + &optional + ignore-cache unread entire) + (let ((strategy (elmo-find-fetch-strategy folder number + ignore-cache + entire))) + (cond ((null strategy) nil) + ((eq (elmo-fetch-strategy-entireness strategy) 'section) + (mime-open-entity + 'elmo-imap + (luna-make-entity 'mime-elmo-imap-location + :folder folder + :number number + :rawbuf rawbuf + :strategy strategy))) + (t + (with-current-buffer rawbuf + (let (buffer-read-only) + (erase-buffer) + (elmo-message-fetch folder number strategy unread))) + (mime-open-entity 'elmo-buffer rawbuf))))) + + +(defconst elmo-mime-inherit-field-list-from-enclosed + '("^Content-.*:" "^Message-Id:" "^Subject:" + "^Encrypted.*:" "^MIME-Version:")) + +(defsubst elmo-mime-make-reassembled-mime-entity (buffer) + (let ((entity (mime-open-entity 'elmo-buffer buffer))) + (mime-elmo-buffer-entity-set-reassembled-internal entity t) + entity)) + +(defun elmo-message-reassembled-mime-entity (folder id rawbuf subject + &optional + ignore-cache + unread) + (let ((cache (elmo-file-cache-get (concat "<" id ">"))) + pieces) + (if (and (not ignore-cache) + (eq (elmo-file-cache-status cache) 'entire)) + ;; use cache + (with-current-buffer rawbuf + (let (buffer-read-only) + (erase-buffer) + (elmo-file-cache-load (elmo-file-cache-path cache) nil)) + (elmo-mime-make-reassembled-mime-entity rawbuf)) + ;; reassemble fragment of the entity + (when (setq pieces (elmo-mime-collect-message/partial-pieces + folder id + (regexp-quote + (if (string-match "[0-9\n]+" subject) + (substring subject 0 (match-beginning 0)) + subject)) + ignore-cache unread)) + (with-current-buffer rawbuf + (let (buffer-read-only + (outer-header (car pieces)) + (pieces (sort (cdr pieces) (lambda (l r) (< (car l) (car r))))) + contents entity) + (erase-buffer) + (while pieces + (insert (cdr (car pieces))) + (setq pieces (cdr pieces))) + (let ((case-fold-search t)) + (save-restriction + (std11-narrow-to-header) + (goto-char (point-min)) + (while (re-search-forward std11-field-head-regexp nil t) + (let ((field-start (match-beginning 0))) + (unless (mime-visible-field-p + (buffer-substring field-start (match-end 0)) + elmo-mime-inherit-field-list-from-enclosed + '(".*")) + (delete-region field-start (1+ (std11-field-end)))))))) + (goto-char (point-min)) + (insert outer-header) + ;; save cache + (elmo-file-cache-save (elmo-file-cache-path cache) nil) + (elmo-mime-make-reassembled-mime-entity rawbuf))))))) + +(defun elmo-mime-collect-message/partial-pieces (folder id subject-regexp + &optional + ignore-cache + unread) + (catch 'complete + (with-temp-buffer + (set-buffer-multibyte nil) + (let (total header pieces) + (elmo-folder-do-each-message-entity (entity folder) + (when (string-match + subject-regexp + (elmo-message-entity-field entity 'subject)) + (erase-buffer) + (let* ((message (elmo-message-mime-entity-internal + folder + (elmo-message-entity-number entity) + (current-buffer) + ignore-cache + unread)) + (ct (mime-entity-content-type message)) + (the-id (or (mime-content-type-parameter ct "id") "")) + number) + (when (string= (downcase the-id) + (downcase id)) + (setq number (string-to-number + (mime-content-type-parameter ct "number"))) + (setq pieces (cons (cons number (mime-entity-body message)) + pieces)) + (when (= number 1) + (let ((case-fold-search t)) + (save-restriction + (std11-narrow-to-header) + (goto-char (point-min)) + (while (re-search-forward std11-field-head-regexp nil t) + (let ((field-start (match-beginning 0))) + (when (mime-visible-field-p + (buffer-substring field-start (match-end 0)) + nil + elmo-mime-inherit-field-list-from-enclosed) + (setq header (concat + header + (buffer-substring + field-start (std11-field-end)) + "\n")))))))) + (unless total + (setq total (ignore-errors + (string-to-number + (mime-content-type-parameter ct "total"))))) + (when (and total + (> total 0) + (>= (length pieces) total)) + (throw 'complete (cons header pieces))))))))) + ;; return value + nil)) + ;; Replacement of mime-display-message. (defun elmo-mime-display-as-is-internal (message @@ -299,28 +479,32 @@ Return non-nil if cache is used." ;; Humm... (set-buffer-multibyte nil) - (mime-insert-entity message) + (insert (mime-entity-body message)) (set-buffer-multibyte t) (decode-coding-region (point-min) (point-max) elmo-mime-display-as-is-coding-system) - (save-restriction - (std11-narrow-to-header) - (run-hooks 'elmo-message-header-inserted-hook)) + (goto-char (point-min)) + (insert "\n") + (goto-char (point-min)) + + (let ((method (cdr (assq original-major-mode + mime-header-presentation-method-alist)))) + (if (functionp method) + (funcall method message nil))) + ;; set original major mode for mime-preview-quit (put-text-property (point-min) (point-max) 'mime-view-situation `((major-mode . ,original-major-mode))) + (put-text-property (point-min) (point-max) + 'elmo-as-is-entity message) (use-local-map (or keymap (if default-keymap-or-function (mime-view-define-keymap default-keymap-or-function) mime-view-mode-default-map))) - (let ((point - (next-single-property-change (point-min) 'mime-view-entity))) - (if point - (goto-char point) - (goto-char (point-min)) - (search-forward "\n\n" nil t))) + (goto-char (point-min)) + (search-forward "\n\n" nil t) (run-hooks 'mime-view-mode-hook) (set-buffer-modified-p nil) (setq buffer-read-only t)