X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=wl%2Fwl-draft.el;h=a2dd943ded34a7c360a2ac2bc1045b56ba07944a;hb=4dee2f09b7c63b19e24942f13b2917addb2a6501;hp=85fcdf96caecfb687536e7a28170987069d72778;hpb=7577ad1b6ed9e227ce088a17bf93eda7d4ef0271;p=elisp%2Fwanderlust.git diff --git a/wl/wl-draft.el b/wl/wl-draft.el index 85fcdf9..a2dd943 100644 --- a/wl/wl-draft.el +++ b/wl/wl-draft.el @@ -30,12 +30,13 @@ ;;; Code: ;; - +(require 'elmo) (require 'sendmail) (require 'wl-template) (require 'emu) (condition-case nil (require 'timezone) (error nil)) (require 'std11) +(require 'eword-encode) (require 'wl-vars) (defvar x-face-add-x-face-version-header) @@ -43,6 +44,7 @@ (defvar mail-from-style) (eval-when-compile + (require 'cl) (require 'static) (require 'elmo-pop3) (defalias-maybe 'x-face-insert 'ignore) @@ -53,6 +55,8 @@ (eval-and-compile (autoload 'wl-addrmgr "wl-addrmgr")) +(autoload 'open-ssl-stream "ssl") + (defvar wl-draft-buffer-message-number nil) (defvar wl-draft-field-completion-list nil) (defvar wl-draft-verbose-send t) @@ -88,10 +92,12 @@ e.g. (\"From\" . \"user@domain2\"))))") (defvar wl-draft-parent-number nil) +(defvar wl-draft-parent-flag nil) -(defconst wl-draft-reply-saved-variables +(defconst wl-draft-parent-variables '(wl-draft-parent-folder - wl-draft-parent-number)) + wl-draft-parent-number + wl-draft-parent-flag)) (defvar wl-draft-config-sub-func-alist '((body . wl-draft-config-sub-body) @@ -119,6 +125,7 @@ e.g. (make-variable-buffer-local 'wl-draft-reply-buffer) (make-variable-buffer-local 'wl-draft-parent-folder) (make-variable-buffer-local 'wl-draft-parent-number) +(make-variable-buffer-local 'wl-draft-parent-flag) (defvar wl-draft-folder-internal nil "Internal variable for caching `opened' draft folder.") @@ -136,16 +143,19 @@ e.g. (list wl-smtp-authenticate-type))))) (smtp-use-sasl (and smtp-sasl-mechanisms t)) (smtp-use-starttls (eq wl-smtp-connection-type 'starttls)) + (smtp-open-connection-function + (if (eq wl-smtp-connection-type 'ssl) + #'open-ssl-stream + smtp-open-connection-function)) + (smtp-end-of-line + (if (eq wl-smtp-connection-type 'ssl) + "\n" + smtp-end-of-line)) smtp-sasl-user-name smtp-sasl-properties sasl-read-passphrase) - (if (and (string= (car smtp-sasl-mechanisms) "DIGEST-MD5") - ;; sendmail bug? - (string-match "^\\([^@]*\\)@\\([^@]*\\)" - wl-smtp-posting-user)) - (setq smtp-sasl-user-name (match-string 1 wl-smtp-posting-user) - smtp-sasl-properties (list 'realm - (match-string 2 wl-smtp-posting-user))) - (setq smtp-sasl-user-name wl-smtp-posting-user - smtp-sasl-properties nil)) + (setq smtp-sasl-user-name wl-smtp-posting-user + smtp-sasl-properties (when wl-smtp-authenticate-realm + (list 'realm + wl-smtp-authenticate-realm))) (setq sasl-read-passphrase (function (lambda (prompt) @@ -214,51 +224,60 @@ e.g. (list (concat wl-draft-mime-bcc-field-name ":"))))))) (defun wl-draft-make-mail-followup-to (recipients) - (if (elmo-list-member - (or wl-user-mail-address-list - (list (wl-address-header-extract-address wl-from))) - recipients) - (let ((rlist (elmo-list-delete - (or wl-user-mail-address-list - (list (wl-address-header-extract-address wl-from))) - recipients - (lambda (elem list) - (elmo-delete-if - (lambda (item) (string= (downcase elem) - (downcase item))) - list))))) - (if (elmo-list-member rlist (mapcar 'downcase - wl-subscribed-mailing-list)) - rlist - (append rlist (list (wl-address-header-extract-address - wl-from))))) - recipients)) + (let ((rlist (wl-address-delete-user-mail-addresses recipients))) + (if (elmo-list-member rlist (mapcar 'downcase + wl-subscribed-mailing-list)) + rlist + (append rlist (list (wl-address-header-extract-address + wl-from)))))) (defun wl-draft-delete-myself-from-cc (to cc) - (let ((myself (or wl-user-mail-address-list - (list (wl-address-header-extract-address wl-from))))) - (cond (wl-draft-always-delete-myself ; always-delete option - (elmo-list-delete myself cc - (lambda (elem list) - (elmo-delete-if - (lambda (item) (string= (downcase elem) - (downcase item))) - list)))) - ((elmo-list-member (append to cc) ; subscribed mailing-list - (mapcar 'downcase wl-subscribed-mailing-list)) - (elmo-list-delete myself cc - (lambda (elem list) - (elmo-delete-if - (lambda (item) (string= (downcase elem) - (downcase item))) - list)))) - (t cc)))) - -(defun wl-draft-forward (original-subject summary-buf) - (let (references parent-folder) + (cond (wl-draft-always-delete-myself ; always-delete option + (wl-address-delete-user-mail-addresses cc)) + ((elmo-list-member (append to cc) ; subscribed mailing-list + (mapcar 'downcase wl-subscribed-mailing-list)) + (wl-address-delete-user-mail-addresses cc)) + (t cc))) + +(defsubst wl-draft-strip-subject-regexp (subject regexp) + "Remove REGEXP from SUBJECT string." + (if (string-match regexp subject) + (substring subject (match-end 0)) + subject)) + +(defun wl-draft-forward-make-subject (original-subject) + "Generate subject string for forwarding." + (cond ((functionp wl-forward-subject-prefix) + (concat (funcall wl-forward-subject-prefix) + original-subject)) + ((stringp wl-forward-subject-prefix) + (concat wl-forward-subject-prefix + (wl-draft-strip-subject-regexp + (or original-subject "") + wl-subject-forward-prefix-regexp))) + (t original-subject))) + +(defun wl-draft-reply-make-subject (original-subject) + "Generate subject string for replying." + (cond ((functionp wl-reply-subject-prefix) + (concat (funcall wl-reply-subject-prefix) + original-subject)) + ((stringp wl-reply-subject-prefix) + (concat wl-reply-subject-prefix + (wl-draft-strip-subject-regexp + (or original-subject "") + wl-subject-re-prefix-regexp))) + (t original-subject))) + +(defun wl-draft-forward (original-subject summary-buf &optional number) + (let (references parent-folder subject) (with-current-buffer summary-buf (setq parent-folder (wl-summary-buffer-folder-name))) + (let ((decoder (mime-find-field-decoder 'Subject 'plain))) + (setq subject (if (and original-subject decoder) + (funcall decoder original-subject) original-subject))) (with-current-buffer (wl-message-get-original-buffer) + (setq subject (wl-draft-forward-make-subject subject)) (setq references (nconc (std11-field-bodies '("References" "In-Reply-To")) (list (std11-field-body "Message-Id")))) @@ -272,19 +291,18 @@ e.g. (get-buffer-window summary-buf) (select-window (get-buffer-window summary-buf))) (wl-draft (list (cons 'To "") - (cons 'Subject - (concat wl-forward-subject-prefix original-subject)) + (cons 'Subject subject) (cons 'References references)) nil nil nil nil parent-folder)) + (setq wl-draft-parent-number number) (goto-char (point-max)) (wl-draft-insert-message) - (mail-position-on-field "To")) - -(defun wl-draft-strip-subject-re (subject) - "Remove \"Re:\" from SUBJECT string. Shamelessly copied from Gnus." - (if (string-match wl-subject-prefix-regexp subject) - (substring subject (match-end 0)) - subject)) + (mail-position-on-field "To") + (setq wl-draft-config-variables + (append wl-draft-parent-variables + wl-draft-config-variables)) + (wl-draft-config-info-operation wl-draft-buffer-message-number 'save) + (run-hooks 'wl-draft-forward-hook)) (defun wl-draft-self-reply-p () "Return t when From address in the current message is user's self one or not." @@ -358,7 +376,7 @@ Reply to author if WITH-ARG is non-nil." (setq to (wl-parse-addresses to) cc (wl-parse-addresses cc)) (with-temp-buffer ; to keep raw buffer unibyte. - (elmo-set-buffer-multibyte default-enable-multibyte-characters) + (set-buffer-multibyte default-enable-multibyte-characters) (setq decoder (mime-find-field-decoder 'Subject 'plain)) (setq subject (if (and subject decoder) (funcall decoder subject) subject)) @@ -376,10 +394,7 @@ Reply to author if WITH-ARG is non-nil." (cons (nth 1 (std11-extract-address-components addr)) (if decoder (funcall decoder addr) addr))) cc))) - (and wl-reply-subject-prefix - (setq subject (concat wl-reply-subject-prefix - (wl-draft-strip-subject-re - (or subject ""))))) + (setq subject (wl-draft-reply-make-subject subject)) (setq in-reply-to (std11-field-body "Message-Id")) (setq references (nconc (std11-field-bodies '("References" "In-Reply-To")) @@ -395,7 +410,7 @@ Reply to author if WITH-ARG is non-nil." (wl-draft-make-mail-followup-to (append to cc))) (setq mail-followup-to (wl-delete-duplicates mail-followup-to nil t))) (with-temp-buffer ; to keep raw buffer unibyte. - (elmo-set-buffer-multibyte default-enable-multibyte-characters) + (set-buffer-multibyte default-enable-multibyte-characters) (setq newsgroups (wl-parse newsgroups "[ \t\f\r\n,]*\\([^ \t\f\r\n,]+\\)") newsgroups (wl-delete-duplicates newsgroups) @@ -452,9 +467,10 @@ Reply to author if WITH-ARG is non-nil." (setq wl-draft-parent-number number) (setq wl-draft-reply-buffer buf) (setq wl-draft-config-variables - (append wl-draft-reply-saved-variables - wl-draft-config-variables))) - (run-hooks 'wl-reply-hook)) + (append wl-draft-parent-variables + wl-draft-config-variables)) + (wl-draft-config-info-operation wl-draft-buffer-message-number 'save)) + (run-hooks 'wl-draft-reply-hook)) (defun wl-draft-reply-position (position) (cond ((eq position 'body) @@ -506,12 +522,13 @@ Reply to author if WITH-ARG is non-nil." (save-restriction (narrow-to-region (point)(point)) (insert - (with-current-buffer mail-reply-buffer - (when decode-it - (decode-mime-charset-region (point-min) (point-max) - wl-mime-charset)) - (buffer-substring-no-properties - (point-min) (point-max)))) + (string-as-multibyte + (with-current-buffer mail-reply-buffer + (when decode-it + (decode-mime-charset-region (point-min) (point-max) + wl-mime-charset)) + (buffer-substring-no-properties + (point-min) (point-max))))) (when ignored-fields (goto-char (point-min)) (wl-draft-delete-fields ignored-fields)) @@ -598,10 +615,7 @@ Reply to author if WITH-ARG is non-nil." (set-buffer (wl-draft (list (cons 'From - (if (member - (nth 1 (std11-extract-address-components from)) - wl-user-mail-address-list) - from)) + (if (wl-address-user-mail-address-p from) from)) (cons 'To to) (cons 'Cc cc) (cons 'Subject subject) @@ -626,17 +640,22 @@ Reply to author if WITH-ARG is non-nil." mail-citation-hook mail-yank-hooks wl-draft-add-references wl-draft-add-in-reply-to wl-draft-cite-function) - (with-current-buffer wl-draft-buffer-cur-summary-buffer - (with-current-buffer wl-message-buffer - (setq original-buffer (wl-message-get-original-buffer)) - (if (zerop - (with-current-buffer original-buffer - (buffer-size))) - (error "No current message")))) - (setq mail-reply-buffer original-buffer) - (wl-draft-yank-from-mail-reply-buffer - nil - wl-ignored-forwarded-headers))) + (if (and wl-draft-buffer-cur-summary-buffer + (with-current-buffer wl-draft-buffer-cur-summary-buffer + (and wl-message-buffer + (with-current-buffer wl-message-buffer + (setq original-buffer (wl-message-get-original-buffer)) + (not (zerop (with-current-buffer original-buffer + (buffer-size)))))))) + (progn + (setq mail-reply-buffer original-buffer) + (wl-draft-yank-from-mail-reply-buffer + nil + wl-ignored-forwarded-headers)) + (when (string= (mime-make-tag "message" "rfc822") + (buffer-substring-no-properties (point-at-bol 0)(point-at-eol 0))) + (delete-region (point-at-bol 0) (1+ (point-at-eol 0)))) + (error "No current message")))) (defun wl-draft-insert-get-message (dummy) (let ((fld (completing-read @@ -655,11 +674,12 @@ Reply to author if WITH-ARG is non-nil." wl-draft-cite-function) (unwind-protect (progn - (elmo-message-fetch (wl-folder-get-elmo-folder fld) - number - ;; No cache. - (elmo-make-fetch-strategy 'entire) - nil mail-reply-buffer) + (with-current-buffer mail-reply-buffer + (erase-buffer) + (elmo-message-fetch (wl-folder-get-elmo-folder fld) + number + ;; No cache. + (elmo-make-fetch-strategy 'entire))) (wl-draft-yank-from-mail-reply-buffer nil)) (kill-buffer mail-reply-buffer)))) @@ -761,23 +781,7 @@ Reply to author if WITH-ARG is non-nil." (or force-kill (yes-or-no-p "Kill Current Draft? "))) (let ((cur-buf (current-buffer))) - (when (and wl-draft-parent-number - (not (string= wl-draft-parent-folder ""))) - (let* ((number wl-draft-parent-number) - (folder-name wl-draft-parent-folder) - (folder (wl-folder-get-elmo-folder folder-name)) - buffer) - (if (and (setq buffer (wl-summary-get-buffer folder-name)) - (with-current-buffer buffer - (string= (wl-summary-buffer-folder-name) - folder-name))) - (with-current-buffer buffer - (elmo-folder-unflag-answered folder (list number)) - (when (wl-summary-jump-to-msg number) - (wl-summary-update-persistent-mark))) - (elmo-folder-open folder 'load-msgdb) - (elmo-folder-unflag-answered folder (list number)) - (elmo-folder-close folder)))) + (run-hooks 'wl-draft-kill-pre-hook) (wl-draft-hide cur-buf) (wl-draft-delete cur-buf))) (message ""))) @@ -1105,7 +1109,7 @@ non-nil." (defun wl-draft-send-mail-with-pop-before-smtp () "Send the prepared message buffer with POP-before-SMTP." (require 'elmo-pop3) - (let ((session + (let ((folder (luna-make-entity 'elmo-pop3-folder :user (or wl-pop-before-smtp-user @@ -1116,16 +1120,17 @@ non-nil." elmo-pop3-default-port) :auth (or wl-pop-before-smtp-authenticate-type elmo-pop3-default-authenticate-type) - :stream-type (or wl-pop-before-smtp-stream-type - elmo-pop3-default-stream-type)))) + :stream-type (elmo-get-network-stream-type + (or wl-pop-before-smtp-stream-type + elmo-pop3-default-stream-type)))) + session) (condition-case error (progn - (elmo-pop3-get-session session) + (setq session (elmo-pop3-get-session folder)) (when session (elmo-network-close-session session))) (error - (elmo-network-close-session session) (unless (string= (nth 1 error) "Unplugged") - (signal (car error)(cdr error)))))) + (signal (car error) (cdr error)))))) (wl-draft-send-mail-with-smtp)) (defun wl-draft-insert-required-fields (&optional force-msgid) @@ -1164,7 +1169,7 @@ If FORCE-MSGID, insert message-id regardless of `wl-insert-message-id'." (re-search-forward "\n[ \t]*\n\n*" nil t)) (replace-match "\n")) (goto-char (point-min)) - (while (re-search-forward + (while (re-search-forward "^[^ \t\n:]+:[ \t]*\\(.*\\(\n[ \t].*\\)*\\)\n" nil t) (when (string= "" (match-string 1)) @@ -1287,6 +1292,7 @@ This variable is valid when `wl-interactive-send' has non-nil value." (goto-char (point-min)) ; to show recipients in header (catch 'done (while t + (discard-input) (message "Send current draft? ") (setq answer (let ((cursor-in-echo-area t)) (read-char))) (cond @@ -1309,8 +1315,9 @@ This variable is valid when `wl-interactive-send' has non-nil value." (t (throw 'done nil))))))) (quit nil)) - (when wl-draft-send-confirm-with-preview - (mime-preview-quit))))) + (when (and wl-draft-send-confirm-with-preview + (eq major-mode 'mime-view-mode)) + (wl-mime-quit-preview))))) (defun wl-draft-send (&optional kill-when-done mes-string) "Send current draft message. @@ -1328,6 +1335,9 @@ If KILL-WHEN-DONE is non-nil, current draft buffer is killed" " *wl-draft-sending-buffer*" (append wl-draft-config-variables (wl-draft-clone-local-variables)))) + (parent-flag wl-draft-parent-flag) + (parent-number wl-draft-parent-number) + (parent-folder wl-draft-parent-folder) (wl-draft-verbose-msg nil) err) (unwind-protect @@ -1348,6 +1358,15 @@ If KILL-WHEN-DONE is non-nil, current draft buffer is killed" ;; (if wl-draft-verbose-send (message "%s" (or mes-string "Sending..."))) + ;; Set flag before send-function because + ;; there's no need to change current mailbox at this time. + ;; If flag is set after send-function, the current mailbox + ;; might changed by Fcc. + ;; It causes a huge loss in the IMAP folder. + (when (and parent-flag parent-number + (not (eq (length parent-folder) 0))) + (wl-folder-set-persistent-mark + parent-folder parent-number parent-flag)) (funcall wl-draft-send-function editing-buffer kill-when-done) ;; Now perform actions on successful sending. (while mail-send-actions @@ -1432,7 +1451,11 @@ If KILL-WHEN-DONE is non-nil, current draft buffer is killed" (insert (if (eq (char-before) ?\n) "" "\n") mail-header-separator "\n"))) (let ((mime-header-encode-method-alist - '((eword-encode-unstructured-field-body)))) + (append + '((eword-encode-unstructured-field-body + . (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-edit-translate-buffer)) (wl-draft-get-header-delimiter t) (setq next-number @@ -1568,14 +1591,8 @@ If KILL-WHEN-DONE is non-nil, current draft buffer is killed" (goto-char (point-max)) (insert-buffer-substring send-mail-buffer header-end) (let ((id (std11-field-body "Message-ID")) - (elmo-enable-disconnected-operation t) - cache-saved) + (elmo-enable-disconnected-operation t)) (while fcc-list - (unless (or cache-saved - (elmo-folder-plugged-p - (wl-folder-get-elmo-folder (car fcc-list)))) - (elmo-file-cache-save id nil) ;; for disconnected operation - (setq cache-saved t)) (if (elmo-folder-append-buffer (wl-folder-get-elmo-folder (eword-decode-string (car fcc-list))) @@ -1628,7 +1645,7 @@ If KILL-WHEN-DONE is non-nil, current draft buffer is killed" (let (wl-demo) (wl-init)) ; returns immediately if already initialized. - + (wl-set-save-drafts) (let (buffer header-alist-internal) (setq buffer (wl-draft-create-buffer parent-folder)) (unless (cdr (assq 'From header-alist)) @@ -1682,8 +1699,7 @@ If KILL-WHEN-DONE is non-nil, current draft buffer is killed" (eq this-command 'wl-summary-forward) (eq this-command 'wl-summary-target-mark-forward) (eq this-command 'wl-summary-target-mark-reply-with-citation))) - (buffer (generate-new-buffer "*draft*")) ; Just for initial name. - change-major-mode-hook) + (buffer (generate-new-buffer "*draft*"))) ; Just for initial name. (set-buffer buffer) ;; switch-buffer according to draft buffer style. (if wl-draft-use-frame @@ -1719,7 +1735,9 @@ If KILL-WHEN-DONE is non-nil, current draft buffer is killed" (funcall wl-draft-buffer-style buffer) (error "Invalid value for wl-draft-buffer-style")))))) (auto-save-mode -1) - (wl-draft-mode) + (let (change-major-mode-hook) + (wl-draft-mode)) + (set-buffer-multibyte t) ; draft buffer is always multibyte. (make-local-variable 'truncate-partial-width-windows) (setq truncate-partial-width-windows nil) (setq truncate-lines wl-draft-truncate-lines) @@ -1966,8 +1984,7 @@ If KILL-WHEN-DONE is non-nil, current draft buffer is killed" (switch-to-buffer-other-frame buffer) (switch-to-buffer buffer)) (set-buffer buffer) - (elmo-message-fetch draft-folder number (elmo-make-fetch-strategy 'entire) - nil (current-buffer)) + (elmo-message-fetch draft-folder number (elmo-make-fetch-strategy 'entire)) (elmo-delete-cr-buffer) (let ((mime-edit-again-ignored-field-regexp "^\\(Content-.*\\|Mime-Version\\):")) @@ -2185,14 +2202,14 @@ Automatically applied in draft sending time." (setq found t))) (if (and found wl-draft-config-matchone) (throw 'done t)) - (setq alist (cdr alist)))) - (if found - (setq wl-draft-config-exec-flag nil)) - (run-hooks 'wl-draft-config-exec-hook) - (put-text-property (point-min)(point-max) 'face nil) - (wl-highlight-message (point-min)(point-max) t) - (setq wl-draft-config-variables - (elmo-uniq-list local-variables)))))) + (setq alist (cdr alist))))) + (if found + (setq wl-draft-config-exec-flag nil)) + (run-hooks 'wl-draft-config-exec-hook) + (put-text-property (point-min)(point-max) 'face nil) + (wl-highlight-message (point-min)(point-max) t) + (setq wl-draft-config-variables + (elmo-uniq-list local-variables))))) (defun wl-draft-replace-field (field content &optional add) (save-excursion @@ -2345,8 +2362,7 @@ Automatically applied in draft sending time." (wl-draft-queue-info-operation (car msgs) 'load) (elmo-message-fetch queue-folder (car msgs) - (elmo-make-fetch-strategy 'entire) - nil (current-buffer)) + (elmo-make-fetch-strategy 'entire)) (condition-case err (setq failure (funcall wl-draft-queue-flush-send-function @@ -2420,6 +2436,10 @@ Automatically applied in draft sending time." (put-text-property (point-min) (point-max) 'face nil) (wl-highlight-message (point-min) (point-max) t)) (set-buffer-modified-p modified)))) + (static-when (featurep 'xemacs) + ;; Cope with one of many XEmacs bugs that `recenter' takes + ;; a long time if there are a lot of invisible text lines. + (redraw-frame)) (recenter n)) ;; insert element from history @@ -2610,6 +2630,13 @@ been implemented yet. Partial support for SWITCH-FUNCTION now supported." wl-user-agent-headers-and-body-alist 'ignore-case))))) t)) +(defun wl-draft-setup-parent-flag (flag) + "Setup a FLAG for parent message." + (when (and (> (length wl-draft-parent-folder) 0) + wl-draft-parent-number) + (setq wl-draft-parent-flag flag) + (wl-draft-config-info-operation wl-draft-buffer-message-number 'save))) + (require 'product) (product-provide (provide 'wl-draft) (require 'wl-version))