X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=wl%2Fwl-mime.el;h=26a405263974cdb0c56eda4f91d59a295f2cb5a1;hb=4dee2f09b7c63b19e24942f13b2917addb2a6501;hp=d07020a2b47cb92c92b3f680ff292edb6a442937;hpb=2ee7a110b10252c266335c4997cab280a45487b6;p=elisp%2Fwanderlust.git diff --git a/wl/wl-mime.el b/wl/wl-mime.el index d07020a..26a4052 100644 --- a/wl/wl-mime.el +++ b/wl/wl-mime.el @@ -28,11 +28,11 @@ ;;; Code: ;; - (require 'mime-view) (require 'mime-edit) (require 'mime-play) (require 'elmo) +(require 'wl-vars) (eval-when-compile (defalias-maybe 'pgg-decrypt-region 'ignore) @@ -66,12 +66,51 @@ has Non-nil value\)" (set-buffer message-buffer) (save-restriction (widen) - (if (wl-region-exists-p) - (wl-mime-preview-follow-current-region) - (mime-preview-follow-current-entity)))) + (cond + ((wl-region-exists-p) + (wl-mime-preview-follow-current-region)) + ((not (wl-message-mime-analysis-p + (wl-message-buffer-display-type))) + (wl-mime-preview-follow-no-mime + (wl-message-buffer-display-type))) + (t + (mime-preview-follow-current-entity))))) (error "No message.")))) ;; modified mime-preview-follow-current-entity from mime-view.el +(defun wl-mime-preview-follow-no-mime (display-type) + "Write follow message to current message, without mime. +It calls following-method selected from variable +`mime-preview-following-method-alist'." + (interactive) + (let* ((mode (mime-preview-original-major-mode 'recursive)) + (new-name (format "%s-no-mime" (buffer-name))) + new-buf min beg end + (entity (get-text-property (point-min) 'elmo-as-is-entity)) + (the-buf (current-buffer)) + fields) + (save-excursion + (goto-char (point-min)) + (setq min (point-min) + beg (re-search-forward "^$" nil t) + end (point-max))) + (save-excursion + (set-buffer (setq new-buf (get-buffer-create new-name))) + (erase-buffer) + (insert-buffer-substring the-buf beg end) + (goto-char (point-min)) + ;; Insert all headers. + (let ((elmo-mime-display-header-analysis + (wl-message-mime-analysis-p display-type 'header))) + (elmo-mime-insert-sorted-header entity)) + (let ((f (cdr (assq mode mime-preview-following-method-alist)))) + (if (functionp f) + (funcall f new-buf) + (message + "Sorry, following method for %s is not implemented yet." + mode)))))) + +;; modified mime-preview-follow-current-entity from mime-view.el (defun wl-mime-preview-follow-current-region () "Write follow message to current region. It calls following-method selected from variable @@ -94,7 +133,8 @@ It calls following-method selected from variable (insert-buffer-substring the-buf r-beg r-end) (goto-char (point-min)) (let ((current-entity - (if (and (eq (mime-entity-media-type entity) 'message) + (if (and entity + (eq (mime-entity-media-type entity) 'message) (eq (mime-entity-media-subtype entity) 'rfc822)) (car (mime-entity-children entity)) entity))) @@ -107,8 +147,7 @@ It calls following-method selected from variable (mime-insert-header current-entity fields) t)) (setq fields (std11-collect-field-names) - current-entity (mime-entity-parent current-entity)) - )) + current-entity (mime-entity-parent current-entity)))) (let ((rest mime-view-following-required-fields-list) field-name ret) (while rest @@ -126,22 +165,62 @@ It calls following-method selected from variable entity field-name)))) (setq entity (mime-entity-parent entity))))) (if ret - (insert (concat field-name ": " ret "\n")) - ))) - (setq rest (cdr rest)) - )) - ) + (insert (concat field-name ": " ret "\n"))))) + (setq rest (cdr rest))))) (let ((f (cdr (assq mode mime-preview-following-method-alist)))) (if (functionp f) (funcall f new-buf) (message "Sorry, following method for %s is not implemented yet." - mode) - )) - ))) + mode)))))) (defalias 'wl-draft-enclose-digest-region 'mime-edit-enclose-digest-region) +(defun wl-draft-preview-attributes-list () + (if (listp (car wl-draft-preview-attributes-list)) + (elmo-uniq-list + (append (and (wl-message-mail-p) + (cdr (assq 'mail wl-draft-preview-attributes-list))) + (and (wl-message-news-p) + (cdr (assq 'news wl-draft-preview-attributes-list))))) + wl-draft-preview-attributes-list)) + +(defun wl-draft-show-attributes-buffer (attribute-values) + (let* ((cur-win (selected-window)) + (size (min + (- (window-height cur-win) + window-min-height 1) + (- (window-height cur-win) + (max + window-min-height + (1+ wl-draft-preview-attributes-buffer-lines)))))) + (split-window cur-win (if (> size 0) size window-min-height)) + (select-window (next-window)) + (let ((pop-up-windows nil)) + (switch-to-buffer (get-buffer-create + wl-draft-preview-attributes-buffer-name))) + (with-current-buffer + (get-buffer wl-draft-preview-attributes-buffer-name) + (setq buffer-read-only t) + (let (buffer-read-only) + (erase-buffer) + (dolist (pair attribute-values) + (insert (capitalize (symbol-name (car pair))) ": " + (format "%s" (or (cdr pair) "")) + "\n")) + (goto-char (point-min)) + (wl-highlight-headers))) + (select-window cur-win))) + +(defun wl-draft-hide-attributes-buffer () + (let (window buffer) + (when (setq window (get-buffer-window + wl-draft-preview-attributes-buffer-name)) + (select-window window) + (delete-window)) + (when (setq buffer (get-buffer wl-draft-preview-attributes-buffer-name)) + (kill-buffer buffer)))) + (defun wl-draft-attribute-recipients () (concat (mapconcat 'identity @@ -172,6 +251,36 @@ It calls following-method selected from variable (or wl-smtp-posting-port (progn (require 'smtp) smtp-service))) +(defun wl-draft-attribute-newsgroups () + (std11-field-body "Newsgroups")) + +(defun wl-draft-nntp-attribute (attribute &optional alternatives) + (let ((config (cdr (elmo-string-matched-assoc + (std11-field-body "newsgroups") + wl-nntp-posting-config-alist))) + entry) + (when (stringp config) + (setq config (list (cons 'server config)))) + (if (setq entry (assq attribute config)) + ;; maybe nil + (cdr entry) + (let (value) + (while alternatives + (if (setq value (symbol-value (car alternatives))) + (setq alternatives nil) + (setq alternatives (cdr alternatives)))) + value)))) + +(defun wl-draft-attribute-nntp-posting-server () + (wl-draft-nntp-attribute + 'server + '(wl-nntp-posting-server elmo-nntp-default-server))) + +(defun wl-draft-attribute-nntp-posting-port () + (wl-draft-nntp-attribute + 'point + '(wl-nntp-posting-port elmo-nntp-default-port))) + (defun wl-draft-attribute-value (attr) (let ((name (symbol-name attr)) fsymbol symbol) @@ -185,10 +294,23 @@ It calls following-method selected from variable ((boundp attr) (symbol-value attr))))) +(defun wl-mime-quit-preview () + "Quitting method for mime-view." + (let* ((temp (and (boundp 'mime-edit-temp-message-buffer) ;; for SEMI <= 1.14.6 + mime-edit-temp-message-buffer)) + (window (selected-window)) + buf) + (mime-preview-kill-buffer) + (set-buffer temp) + (setq buf mime-edit-buffer) + (kill-buffer temp) + (select-window window) + (switch-to-buffer buf))) + (defun wl-draft-preview-message () "Preview editing message." (interactive) - (let* (attribute-list + (let* (attribute-values (orig-buffer (current-buffer)) (current-point (point)) (config-exec-flag wl-draft-config-exec-flag) @@ -202,75 +324,46 @@ It calls following-method selected from variable (symbol-value 'mime-header-encode-method-alist)))) mime-view-ignored-field-list ; all header. (mime-edit-translate-buffer-hook - (append - (list - (lambda () - (let ((wl-draft-config-exec-flag config-exec-flag) - (wl-draft-parent-folder parent-folder) - (copy-buffer (current-buffer))) + (cons + (lambda () + (let ((wl-draft-config-exec-flag config-exec-flag) + (wl-draft-parent-folder parent-folder) + (copy-buffer (current-buffer))) + (wl-copy-local-variables + orig-buffer + copy-buffer (with-current-buffer orig-buffer - (wl-copy-local-variables - orig-buffer - copy-buffer - (append wl-draft-config-variables - (wl-draft-clone-local-variables)))) - (goto-char current-point) - (run-hooks 'wl-draft-send-hook) - (condition-case err - (setq attribute-list - (mapcar - (lambda (attr) - (cons attr (wl-draft-attribute-value attr))) - wl-draft-preview-attributes-list)) - (error - (kill-buffer (current-buffer)) - (signal (car err) (cdr err))))))) + (append wl-draft-config-variables + (wl-draft-clone-local-variables)))) + (goto-char current-point) + (run-hooks 'wl-draft-send-hook) + (condition-case err + (setq attribute-values + (mapcar + (lambda (attr) + (cons attr (wl-draft-attribute-value attr))) + (if wl-draft-preview-attributes + (wl-draft-preview-attributes-list) + '(recipients)))) + (error + (kill-buffer (current-buffer)) + (signal (car err) (cdr err)))))) mime-edit-translate-buffer-hook))) (mime-edit-preview-message) + (make-local-variable 'mime-preview-quitting-method-alist) + (setq mime-preview-quitting-method-alist + '((mime-temp-message-mode . wl-mime-quit-preview))) (let ((buffer-read-only nil)) (when wl-highlight-body-too (wl-highlight-body)) (run-hooks 'wl-draft-preview-message-hook)) - (make-local-variable 'kill-buffer-hook) - (add-hook 'kill-buffer-hook - (lambda () - (when (get-buffer-window - wl-draft-preview-attributes-buffer-name) - (select-window (get-buffer-window - wl-draft-preview-attributes-buffer-name)) - (delete-window)) - (when (get-buffer wl-draft-preview-attributes-buffer-name) - (kill-buffer (get-buffer - wl-draft-preview-attributes-buffer-name))))) - (if (not wl-draft-preview-attributes) - (message (concat "Recipients: " - (cdr (assq 'recipients attribute-list)))) - (ignore-errors ; in case when the window is too small - (let* ((cur-win (selected-window)) - (size (min - (- (window-height cur-win) - window-min-height 1) - (- (window-height cur-win) - (max - window-min-height - (1+ wl-draft-preview-attributes-buffer-lines)))))) - (split-window cur-win (if (> size 0) size window-min-height)) - (select-window (next-window)) - (let ((pop-up-windows nil)) - (switch-to-buffer (get-buffer-create - wl-draft-preview-attributes-buffer-name))) - (with-current-buffer - (get-buffer wl-draft-preview-attributes-buffer-name) - (setq buffer-read-only t) - (let (buffer-read-only) - (erase-buffer) - (dolist (pair attribute-list) - (insert (capitalize (symbol-name (car pair))) ": " - (format "%s" (or (cdr pair) "")) - "\n")) - (goto-char (point-min)) - (wl-highlight-headers))) - (select-window cur-win)))))) + (make-local-hook 'kill-buffer-hook) + (add-hook 'kill-buffer-hook #'wl-draft-hide-attributes-buffer nil t) + (if wl-draft-preview-attributes + (ignore-errors ; in case when the window is too small + (wl-draft-show-attributes-buffer attribute-values)) + (message (concat "Recipients: " + (cdr (assq 'recipients attribute-values))))))) (defalias 'wl-draft-caesar-region 'mule-caesar-region) @@ -303,8 +396,6 @@ It calls following-method selected from variable (elmo-message-fetch (wl-folder-get-elmo-folder folder) number (elmo-make-fetch-strategy 'entire) - nil - (current-buffer) 'unread) (mime-parse-buffer nil))) @@ -331,6 +422,7 @@ It calls following-method selected from variable (widen) (let* ((entity (get-text-property (point) 'mime-view-entity)) (node-id (mime-entity-node-id entity)) + (filename (mime-entity-safe-filename entity)) (header-start (mime-buffer-entity-header-start-internal entity)) (body-end (mime-buffer-entity-body-end-internal entity)) (folder (wl-folder-get-elmo-folder wl-message-buffer-cur-folder)) @@ -342,8 +434,9 @@ It calls following-method selected from variable (with-current-buffer orig-buf (unless (string-equal (buffer-string) - (elmo-message-fetch folder number - (elmo-make-fetch-strategy 'entire))) + (elmo-message-fetch-string + folder number + (elmo-make-fetch-strategy 'entire))) (error "Buffer content differs from actual message"))) (when (and (elmo-folder-writable-p folder) (buffer-live-p orig-buf) @@ -355,7 +448,17 @@ It calls following-method selected from variable (insert-buffer orig-buf) (delete-region header-start body-end) (goto-char header-start) - (insert "Content-Type: text/plain; charset=US-ASCII\n\n") + (insert "Content-Type: text/plain; charset=US-ASCII\n") + (when filename + (insert + "Content-Disposition:" + (mime-encode-field-body + (concat "" + (and filename + (concat " inline; filename=" (std11-wrap-as-quoted-string filename)))) + "Content-Disposition") + "\n")) + (insert "\n") (insert "** This part has been removed by Wanderlust **\n\n") (elmo-folder-append-buffer folder)) @@ -630,7 +733,7 @@ With ARG, ask destination folder." (mime-decrypt-application/pgp-encrypted entity situation) (setq wl-message-buffer-cur-summary-buffer summary-buffer) (setq wl-message-buffer-original-buffer original-buffer))) - + ;;; Setup methods. (defun wl-mime-setup ()