X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;ds=inline;f=wl%2Fwl-mime.el;h=d07020a2b47cb92c92b3f680ff292edb6a442937;hb=778808cac571b2066f34b3eda74e30cb15db5354;hp=e0578371fd2776b926661b13e3b30273161727e6;hpb=c88afad335636e1bdf21217ad36f90e4e19e5df7;p=elisp%2Fwanderlust.git diff --git a/wl/wl-mime.el b/wl/wl-mime.el index e057837..d07020a 100644 --- a/wl/wl-mime.el +++ b/wl/wl-mime.el @@ -59,15 +59,17 @@ has Non-nil value\)" (function wl-draft-yank-to-draft-buffer)))) (mime-preview-following-method-alist (list (cons 'wl-original-message-mode - (function wl-draft-yank-to-draft-buffer))))) - (if (get-buffer (wl-current-message-buffer)) + (function wl-draft-yank-to-draft-buffer)))) + (message-buffer (wl-current-message-buffer))) + (if message-buffer (save-excursion - (set-buffer (wl-current-message-buffer)) + (set-buffer message-buffer) (save-restriction (widen) (if (wl-region-exists-p) (wl-mime-preview-follow-current-region) - (mime-preview-follow-current-entity))))))) + (mime-preview-follow-current-entity)))) + (error "No message.")))) ;; modified mime-preview-follow-current-entity from mime-view.el (defun wl-mime-preview-follow-current-region () @@ -133,18 +135,61 @@ It calls following-method selected from variable (if (functionp f) (funcall f new-buf) (message - (format - "Sorry, following method for %s is not implemented yet." - mode)) + "Sorry, following method for %s is not implemented yet." + mode) )) ))) (defalias 'wl-draft-enclose-digest-region 'mime-edit-enclose-digest-region) +(defun wl-draft-attribute-recipients () + (concat (mapconcat + 'identity + (wl-draft-deduce-address-list + (current-buffer) + (point-min) + (save-excursion + (goto-char (point-min)) + (re-search-forward + (concat + "^" + (regexp-quote mail-header-separator) + "$") + nil t) + (point))) + ", "))) + +(defun wl-draft-attribute-envelope-from () + (or wl-envelope-from + (wl-address-header-extract-address wl-from))) + +(defun wl-draft-attribute-smtp-posting-server () + (or wl-smtp-posting-server + (progn (require 'smtp) smtp-server) + "localhost")) + +(defun wl-draft-attribute-smtp-posting-port () + (or wl-smtp-posting-port + (progn (require 'smtp) smtp-service))) + +(defun wl-draft-attribute-value (attr) + (let ((name (symbol-name attr)) + fsymbol symbol) + (cond ((and (setq fsymbol (intern-soft + (format "wl-draft-attribute-%s" name))) + (fboundp fsymbol)) + (funcall fsymbol)) + ((and (setq symbol (intern-soft (format "wl-%s" name))) + (boundp symbol)) + (symbol-value symbol)) + ((boundp attr) + (symbol-value attr))))) + (defun wl-draft-preview-message () "Preview editing message." (interactive) - (let* (recipients-message + (let* (attribute-list + (orig-buffer (current-buffer)) (current-point (point)) (config-exec-flag wl-draft-config-exec-flag) (parent-folder wl-draft-parent-folder) @@ -152,47 +197,80 @@ It calls following-method selected from variable (mime-header-encode-method-alist (append '((wl-draft-eword-encode-address-list - . (To Cc Bcc Resent-To Resent-Cc Bcc Resent-Bcc))) + . (To Cc Bcc Resent-To Resent-Cc Resent-Bcc From))) (if (boundp 'mime-header-encode-method-alist) (symbol-value 'mime-header-encode-method-alist)))) mime-view-ignored-field-list ; all header. (mime-edit-translate-buffer-hook (append (list - (function - (lambda () - (let ((wl-draft-config-exec-flag config-exec-flag) - (wl-draft-parent-folder parent-folder)) - (goto-char current-point) - (run-hooks 'wl-draft-send-hook) - (setq recipients-message - (condition-case err - (concat "Recipients: " - (mapconcat - 'identity - (wl-draft-deduce-address-list - (current-buffer) - (point-min) - (save-excursion - (goto-char (point-min)) - (re-search-forward - (concat - "^" - (regexp-quote mail-header-separator) - "$") - nil t) - (point))) - ", ")) - (error - (kill-buffer (current-buffer)) - (signal (car err) (cdr err))))))))) + (lambda () + (let ((wl-draft-config-exec-flag config-exec-flag) + (wl-draft-parent-folder parent-folder) + (copy-buffer (current-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))))))) mime-edit-translate-buffer-hook))) (mime-edit-preview-message) (let ((buffer-read-only nil)) (when wl-highlight-body-too (wl-highlight-body)) (run-hooks 'wl-draft-preview-message-hook)) - (message recipients-message))) + (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)))))) (defalias 'wl-draft-caesar-region 'mule-caesar-region) @@ -279,7 +357,7 @@ It calls following-method selected from variable (goto-char header-start) (insert "Content-Type: text/plain; charset=US-ASCII\n\n") (insert "** This part has been removed by Wanderlust **\n\n") - (elmo-folder-append-buffer folder t)) + (elmo-folder-append-buffer folder)) (elmo-folder-move-messages folder (list number) @@ -312,59 +390,47 @@ It calls following-method selected from variable (message "Cannot find pgp encrypted region"))) (message "Cannot find pgp encrypted region")))) -(defun wl-message-verify-pgp-nonmime (&optional arg) - "Verify PGP signed region. -With ARG, ask coding system and encode the region with it before verifying." - (interactive "P") +(defun wl-message-verify-pgp-nonmime () + "Verify PGP signed region" + (interactive) (require 'pgg) (save-excursion (beginning-of-line) - (let ((msg-buf (current-buffer)) - beg end status m-beg) - (if (and (when (or (re-search-forward "^-+END PGP SIGNATURE-+$" nil t) - (re-search-backward "^-+END PGP SIGNATURE-+$" nil t)) - (setq end (match-end 0))) - (setq beg (re-search-backward "^-+BEGIN PGP SIGNED MESSAGE-+$" nil t))) - (progn - (if arg - (with-temp-buffer - (insert-buffer-substring msg-buf beg end) - (set-mark (point-min)) - (goto-char (point-max)) - (call-interactively 'encode-coding-region) - (setq status (pgg-verify-region (point-min) (point-max) nil 'fetch))) - (let* ((situation (mime-preview-find-boundary-info)) - (p-end (aref situation 1)) - (entity (aref situation 2)) - (count 0)) - (goto-char p-end) - (while (< beg (point)) - (if (re-search-backward "^-+BEGIN PGP SIGNED MESSAGE-+$" nil t) - (setq count (+ count 1)) - (debug))) - (with-temp-buffer - (insert (mime-entity-body entity)) - (goto-char (point-max)) - (while (> count 0) - (if (re-search-backward "^-+BEGIN PGP SIGNED MESSAGE-+$" nil t) - (setq count (- count 1)) - (debug))) - (let ((r-beg (point)) - (r-end (re-search-forward "^-+END PGP SIGNATURE-+$" nil t))) - (if r-end - (setq status (pgg-verify-region r-beg r-end nil 'fetch)) - (debug)))))) - (mime-show-echo-buffer) - (set-buffer mime-echo-buffer-name) - (set-window-start - (get-buffer-window mime-echo-buffer-name) - (point-max)) - (setq m-beg (point)) - (insert-buffer-substring - (if status pgg-output-buffer pgg-errors-buffer)) - (encode-coding-region m-beg (point) buffer-file-coding-system) - (decode-coding-region m-beg (point) wl-cs-autoconv)) - (message "Cannot find pgp signed region"))))) + (if (and (or (re-search-forward "^-+END PGP SIGNATURE-+$" nil t) + (re-search-backward "^-+END PGP SIGNATURE-+$" nil t)) + (re-search-backward "^-+BEGIN PGP SIGNED MESSAGE-+$" nil t)) + (let (status) + (let* ((beg (point)) + (situation (mime-preview-find-boundary-info)) + (p-end (aref situation 1)) + (entity (aref situation 2)) + (count 0)) + (goto-char p-end) + (while (< beg (point)) + (if (re-search-backward "^-+BEGIN PGP SIGNED MESSAGE-+$" nil t) + (setq count (+ count 1)) + (debug))) + (with-temp-buffer + (set-buffer-multibyte nil) + (insert (mime-entity-body entity)) + (goto-char (point-max)) + (while (> count 0) + (if (re-search-backward "^-+BEGIN PGP SIGNED MESSAGE-+$" nil t) + (setq count (- count 1)) + (debug))) + (let ((r-beg (point)) + (r-end (re-search-forward "^-+END PGP SIGNATURE-+$" nil t))) + (if r-end + (setq status (pgg-verify-region r-beg r-end nil 'fetch)) + (debug))))) + (mime-show-echo-buffer) + (set-buffer mime-echo-buffer-name) + (set-window-start + (get-buffer-window mime-echo-buffer-name) + (point-max)) + (insert-buffer-substring + (if status pgg-output-buffer pgg-errors-buffer))) + (message "Cannot find pgp signed region")))) ;; XXX: encrypted multipart isn't represented as multipart (defun wl-mime-preview-application/pgp (parent-entity entity situation) @@ -427,9 +493,7 @@ With ARG, ask coding system and encode the region with it before verifying." (car (mime-entity-children message-entity))) (with-temp-buffer (insert (mime-entity-body message-entity)) - (elmo-folder-append-buffer - target - (mime-entity-fetch-field entity "Message-ID"))))) + (elmo-folder-append-buffer target)))) number)) (defun wl-summary-burst (&optional arg) @@ -438,15 +502,23 @@ With ARG, ask destination folder." (interactive "P") (let ((raw-buf (wl-summary-get-original-buffer)) (view-buf wl-message-buffer) - children message-entity content-type target) + message-entity target) (save-excursion - (setq target wl-summary-buffer-elmo-folder) - (when (or arg (not (elmo-folder-writable-p target))) - (let ((fld (wl-summary-read-folder wl-default-folder "to extract to"))) - (setq target (wl-folder-get-elmo-folder fld)))) + (when (and (null arg) + (elmo-folder-writable-p wl-summary-buffer-elmo-folder)) + (setq target wl-summary-buffer-elmo-folder)) + (while (null target) + (let ((name (wl-summary-read-folder wl-default-folder + "to extract to"))) + (setq target (wl-folder-get-elmo-folder name)) + (unless (elmo-folder-writable-p target) + (message "%s is not writable" name) + (setq target nil) + (sit-for 1)))) (wl-summary-set-message-buffer-or-redisplay) (with-current-buffer view-buf - (setq message-entity (get-text-property (point-min) 'mime-view-entity))) + (setq message-entity + (get-text-property (point-min) 'mime-view-entity))) (when message-entity (message "Bursting...") (with-current-buffer raw-buf @@ -454,18 +526,22 @@ With ARG, ask destination folder." (message "Bursting...done")) (if (elmo-folder-plugged-p target) (elmo-folder-check target))) - (wl-summary-sync-update))) + (when (and target + (string= wl-summary-buffer-folder-name + (elmo-folder-name-internal target))) + (save-excursion (wl-summary-sync-update))))) ;; internal variable. (defvar wl-mime-save-directory nil "Last saved directory.") ;;; Yet another save method. (defun wl-mime-save-content (entity situation) - (let ((filename (read-file-name "Save to file: " - (expand-file-name - (or (mime-entity-safe-filename entity) - ".") - (or wl-mime-save-directory - wl-temporary-file-directory))))) + (let ((filename (expand-file-name + (read-file-name "Save to file: " + (expand-file-name + (or (mime-entity-safe-filename entity) + ".") + (or wl-mime-save-directory + wl-temporary-file-directory)))))) (while (file-directory-p filename) (setq filename (read-file-name "Please set filename (not directory): " filename))) @@ -480,11 +556,9 @@ With ARG, ask destination folder." (defun wl-mime-combine-message/partial-pieces (entity situation) "Internal method for wl to combine message/partial messages automatically." (interactive) - (let* ((msgdb (save-excursion - (set-buffer wl-message-buffer-cur-summary-buffer) - (wl-summary-buffer-msgdb))) + (let* ((folder (with-current-buffer wl-message-buffer-cur-summary-buffer + wl-summary-buffer-elmo-folder)) (mime-display-header-hook 'wl-highlight-headers) - (folder wl-message-buffer-cur-folder) (id (or (cdr (assoc "id" situation)) "")) (mother (current-buffer)) (summary-buf wl-message-buffer-cur-summary-buffer) @@ -515,18 +589,16 @@ With ARG, ask destination folder." wl-summary-buffer-mime-charset))) (if (string-match "[0-9\n]+" subject-id) (setq subject-id (substring subject-id 0 (match-beginning 0)))) - (setq overviews (elmo-msgdb-get-overview msgdb)) (catch 'tag - (while overviews + (elmo-folder-do-each-message-entity (entity folder) (when (string-match (regexp-quote subject-id) - (elmo-msgdb-overview-entity-get-subject (car overviews))) + (elmo-message-entity-field entity 'subject 'decode)) (let* ((message ;; request message at the cursor in Subject buffer. (wl-message-request-partial - folder - (elmo-msgdb-overview-entity-get-number - (car overviews)))) + (elmo-folder-name-internal folder) + (elmo-message-entity-number entity))) (situation (mime-entity-situation message)) (the-id (or (cdr (assoc "id" situation)) ""))) (when (string= (downcase the-id) @@ -534,8 +606,7 @@ With ARG, ask destination folder." (with-current-buffer mother (mime-store-message/partial-piece message situation)) (if (file-exists-p full-file) - (throw 'tag nil))))) - (setq overviews (cdr overviews))) + (throw 'tag nil)))))) (message "Not all partials found."))))) (defun wl-mime-display-text/plain (entity situation) @@ -545,7 +616,7 @@ With ARG, ask destination folder." (defun wl-mime-display-header (entity situation) (let ((elmo-message-ignored-field-list - (if wl-message-buffer-all-header-flag + (if wl-message-buffer-require-all-header nil wl-message-ignored-field-list)) (elmo-message-visible-field-list wl-message-visible-field-list)