X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=wl%2Fwl-draft.el;h=a5726639b4ac200818e3130b5e0fe3968d05ccb3;hb=488c0f7aaf37a4ce73f2ece8da14b8aec6db0202;hp=7852e1ee9ef6b05533e69d9559b83a6f5bfad8ea;hpb=f3d9904c7ca0f96e7ba0bcae3771145428e19008;p=elisp%2Fwanderlust.git diff --git a/wl/wl-draft.el b/wl/wl-draft.el index 7852e1e..0e64e1b 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,8 @@ (defvar mail-from-style) (eval-when-compile + (require 'cl) + (require 'static) (require 'elmo-pop3) (defalias-maybe 'x-face-insert 'ignore) (defalias-maybe 'x-face-insert-version-header 'ignore) @@ -52,8 +55,9 @@ (eval-and-compile (autoload 'wl-addrmgr "wl-addrmgr")) -(defvar wl-draft-buf-name "Draft") -(defvar wl-draft-buffer-file-name nil) +(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) (defvar wl-draft-verbose-msg nil) @@ -73,7 +77,27 @@ (defvar wl-draft-reedit nil) (defvar wl-draft-reply-buffer nil) (defvar wl-draft-forward nil) -(defvar wl-draft-parent-folder nil) +(defvar wl-draft-doing-mime-bcc nil) + +(defvar wl-draft-parent-folder nil + "Folder name of the summary in which current draft is invoked. +This variable is local in each draft buffer. +You can refer its value in `wl-draft-config-alist'. + +e.g. +\(setq wl-draft-config-alist + '(((string-match \".*@domain1$\" wl-draft-parent-folder) + (\"From\" . \"user@domain1\")) + ((string-match \".*@domain2$\" wl-draft-parent-folder) + (\"From\" . \"user@domain2\"))))") + +(defvar wl-draft-parent-number nil) +(defvar wl-draft-parent-flag nil) + +(defconst wl-draft-parent-variables + '(wl-draft-parent-folder + wl-draft-parent-number + wl-draft-parent-flag)) (defvar wl-draft-config-sub-func-alist '((body . wl-draft-config-sub-body) @@ -91,7 +115,7 @@ (template . wl-draft-config-sub-template) (x-face . wl-draft-config-sub-x-face))) -(make-variable-buffer-local 'wl-draft-buffer-file-name) +(make-variable-buffer-local 'wl-draft-buffer-message-number) (make-variable-buffer-local 'wl-draft-buffer-cur-summary-buffer) (make-variable-buffer-local 'wl-draft-config-variables) (make-variable-buffer-local 'wl-draft-config-exec-flag) @@ -100,39 +124,43 @@ (make-variable-buffer-local 'wl-draft-fcc-list) (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.") (defsubst wl-smtp-password-key (user mechanism server) (format "SMTP:%s/%s@%s" user mechanism server)) (defmacro wl-smtp-extension-bind (&rest body) - (` (let* ((smtp-sasl-mechanisms - (if wl-smtp-authenticate-type - (mapcar 'upcase - (if (listp wl-smtp-authenticate-type) - wl-smtp-authenticate-type - (list wl-smtp-authenticate-type))))) - (smtp-use-sasl (and smtp-sasl-mechanisms t)) - (smtp-use-starttls (eq wl-smtp-connection-type 'starttls)) - 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 sasl-read-passphrase - (function - (lambda (prompt) - (elmo-get-passwd - (wl-smtp-password-key - smtp-sasl-user-name - (car smtp-sasl-mechanisms) - smtp-server))))) - (,@ body)))) + `(let* ((smtp-sasl-mechanisms + (if wl-smtp-authenticate-type + (mapcar 'upcase + (if (listp wl-smtp-authenticate-type) + wl-smtp-authenticate-type + (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-sasl-user-name smtp-sasl-properties sasl-read-passphrase) + (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) + (elmo-get-passwd + (wl-smtp-password-key + smtp-sasl-user-name + (car smtp-sasl-mechanisms) + smtp-server))))) + ,@body)) (defun wl-draft-insert-date-field () "Insert Date field." @@ -142,55 +170,18 @@ "Insert From field." ;; Put the "From:" field in unless for some odd reason ;; they put one in themselves. - (let* ((login (or user-mail-address (user-login-name))) - (fullname (user-full-name))) - (cond ((eq mail-from-style 'angles) - (insert "From: " fullname) - (let ((fullname-start (+ (point-min) (length "From: "))) - (fullname-end (point-marker))) - (goto-char fullname-start) - ;; Look for a character that cannot appear unquoted - ;; according to RFC 822. - (if (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]" - fullname-end 1) - (progn - ;; Quote fullname, escaping specials. - (goto-char fullname-start) - (insert "\"") - (while (re-search-forward "[\"\\]" - fullname-end 1) - (replace-match "\\\\\\&" t)) - (insert "\"")))) - (insert " <" login ">\n")) - ((eq mail-from-style 'parens) - (insert "From: " login " (") - (let ((fullname-start (point))) - (insert fullname) - (let ((fullname-end (point-marker))) - (goto-char fullname-start) - ;; RFC 822 says \ and nonmatching parentheses - ;; must be escaped in comments. - ;; Escape every instance of ()\ ... - (while (re-search-forward "[()\\]" fullname-end 1) - (replace-match "\\\\\\&" t)) - ;; ... then undo escaping of matching parentheses, - ;; including matching nested parentheses. - (goto-char fullname-start) - (while (re-search-forward - "\\(\\=\\|[^\\]\\(\\\\\\\\\\)*\\)\\\\(\\(\\([^\\]\\|\\\\\\\\\\)*\\)\\\\)" - fullname-end 1) - (replace-match "\\1(\\3)" t) - (goto-char fullname-start)))) - (insert ")\n")) - ((not mail-from-style) - (insert "From: " login "\n"))))) + (let (from) + (condition-case err + (setq from (wl-draft-eword-encode-address-list wl-from)) + (error (error "Please look at `wl-from' again"))) + (insert "From: " from "\n"))) (defun wl-draft-insert-x-face-field () "Insert X-Face header." (interactive) (if (not (file-exists-p wl-x-face-file)) (error "File %s does not exist" wl-x-face-file) - (beginning-of-buffer) + (goto-char (point-min)) (search-forward mail-header-separator nil t) (beginning-of-line) (wl-draft-insert-x-face-field-here) @@ -199,7 +190,7 @@ (defun wl-draft-insert-x-face-field-here () "Insert X-Face field at point." (let ((x-face-string (elmo-get-file-string wl-x-face-file))) - (when (string-match "^[ \t]*" x-face-string) + (when (string-match "^\\(X-Face:\\)?[ \t\n]*" x-face-string) (setq x-face-string (substring x-face-string (match-end 0)))) (insert "X-Face: " x-face-string)) (when (not (= (preceding-char) ?\n)) ; for chomped (choped) x-face-string @@ -212,43 +203,77 @@ (defun wl-draft-setup () (let ((field wl-draft-fields) - ret-val) + cl) (while field - (setq ret-val (append ret-val - (list (cons (concat (car field) " ") - (concat (car field) " "))))) + (setq cl (append cl + (list (cons (concat (car field) " ") + (concat (car field) " "))))) (setq field (cdr field))) - (setq wl-draft-field-completion-list ret-val))) + (setq cl + (cons (cons (concat wl-draft-mime-bcc-field-name ": ") + (concat wl-draft-mime-bcc-field-name ": ")) + cl)) + (setq wl-draft-field-completion-list cl) + (setq wl-address-complete-header-regexp + (wl-regexp-opt + (append wl-address-complete-header-list + (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))) - (copy-sequence recipients)))) - (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)) - ((elmo-list-member (append to cc) ; subscribed mailing-list - (mapcar 'downcase wl-subscribed-mailing-list)) - (elmo-list-delete myself cc)) - (t cc)))) - -(defun wl-draft-forward (original-subject summary-buf) - (let (references) + (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")))) @@ -258,82 +283,96 @@ references (wl-delete-duplicates references) references (when references (mapconcat 'identity references "\n\t")))) - (wl-draft "" (concat "Forward: " original-subject) - nil nil references nil nil nil nil nil nil summary-buf)) + (and wl-draft-use-frame + (get-buffer-window summary-buf) + (select-window (get-buffer-window summary-buf))) + (wl-draft (list (cons 'To "") + (cons 'Subject subject) + (cons 'References references)) + nil nil nil nil parent-folder 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 lines. 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." + (wl-address-user-mail-address-p (or (elmo-field-body "From") ""))) + +(defun wl-draft-find-reply-headers (rule-symbol) + (let ((rule-list (symbol-value rule-symbol)) + condition-match-p result) + (setq condition-match-p + (lambda (condition) + (cond ((stringp condition) + (std11-field-body condition)) + ((functionp condition) + (funcall condition)) + ((consp condition) + (and (funcall condition-match-p (car condition)) + (funcall condition-match-p (cdr condition)))) + ((null condition)) + (t + (error "Unkown condition in `%s'" rule-symbol))))) + (while (and (null result) rule-list) + (let ((rule (car rule-list))) + (when (funcall condition-match-p (car rule)) + (setq result (cdr rule))) + (setq rule-list (cdr rule-list)))) + result)) -(defun wl-draft-reply-list-symbol (with-arg) - "Return symbol `wl-draft-reply-*-argument-list' match condition. -Check WITH-ARG and From: field." - (if (wl-address-user-mail-address-p (or (elmo-field-body "From") "")) - (if with-arg - 'wl-draft-reply-myself-with-argument-list - 'wl-draft-reply-myself-without-argument-list) - (if with-arg - 'wl-draft-reply-with-argument-list - 'wl-draft-reply-without-argument-list))) - -(defun wl-draft-reply (buf with-arg summary-buf) - "Reply to BUF buffer message. -Reply to author if WITH-ARG is non-nil." +(defun wl-draft-reply (buf with-arg summary-buf &optional number) + "Create draft for replying to the message in buffer BUF. +Recipients are prepared along `wl-draft-reply-without-argument-list', +or `wl-draft-reply-with-argument-list' if WITH-ARG argument is non-nil." ;;;(save-excursion - (let (r-list + (let ((rule-list (if with-arg + 'wl-draft-reply-with-argument-list + 'wl-draft-reply-without-argument-list)) + reply-headers to mail-followup-to cc subject in-reply-to references newsgroups - from to-alist cc-alist decoder parent-folder) - (set-buffer summary-buf) - (setq parent-folder (wl-summary-buffer-folder-name)) - (set-buffer buf) - (setq r-list (symbol-value (wl-draft-reply-list-symbol with-arg))) - (catch 'done - (while r-list - (when (let ((condition (car (car r-list)))) - (cond ((stringp condition) - (std11-field-body condition)) - ((listp condition) - (catch 'done - (while condition - (if (not (std11-field-body (car condition))) - (throw 'done nil)) - (setq condition (cdr condition))) - t)) - ((symbolp condition) - (funcall condition)))) - (let ((r-to-list (nth 0 (cdr (car r-list)))) - (r-cc-list (nth 1 (cdr (car r-list)))) - (r-ng-list (nth 2 (cdr (car r-list))))) - (when (and (member "Followup-To" r-ng-list) - (string= (std11-field-body "Followup-To") "poster")) - (setq r-to-list (cons "From" r-to-list)) - (setq r-ng-list (delete "Followup-To" (copy-sequence r-ng-list)))) - (setq to (wl-concat-list (cons to - (elmo-multiple-fields-body-list - r-to-list)) - ",")) - (setq cc (wl-concat-list (cons cc - (elmo-multiple-fields-body-list - r-cc-list)) - ",")) - (setq newsgroups (wl-concat-list (cons newsgroups - (std11-field-bodies - r-ng-list)) - ","))) - (throw 'done nil)) - (setq r-list (cdr r-list))) - (error "No match field: check your `%s'" - (symbol-name (wl-draft-reply-list-symbol with-arg)))) + to-alist cc-alist decoder parent-folder) + (when (buffer-live-p summary-buf) + (with-current-buffer summary-buf + (setq parent-folder (wl-summary-buffer-folder-name)))) + (set-buffer (or buf mime-mother-buffer)) + (setq reply-headers + (or (wl-draft-find-reply-headers rule-list) + (error "No match field: check your `%s'" rule-list))) + (let ((r-to-list (nth 0 reply-headers)) + (r-cc-list (nth 1 reply-headers)) + (r-ng-list (nth 2 reply-headers))) + (setq to (wl-concat-list + (nconc + (if (functionp r-to-list) + (funcall r-to-list) + (elmo-multiple-fields-body-list r-to-list)) + (and (member "Followup-To" r-ng-list) + (string= (std11-field-body "Followup-To") "poster") + (progn + (setq r-ng-list (delete "Followup-To" + (copy-sequence r-ng-list))) + (elmo-multiple-fields-body-list '("From"))))) + ",")) + (setq cc (wl-concat-list + (if (functionp r-cc-list) + (funcall r-cc-list) + (elmo-multiple-fields-body-list r-cc-list)) + ",")) + (setq newsgroups (wl-concat-list + (if (functionp r-ng-list) + (funcall r-ng-list) + (std11-field-bodies r-ng-list)) + ","))) (setq subject (std11-field-body "Subject")) (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)) @@ -351,10 +390,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")) @@ -370,8 +406,8 @@ 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) - (setq newsgroups (wl-parse newsgroups + (set-buffer-multibyte default-enable-multibyte-characters) + (setq newsgroups (elmo-parse newsgroups "[ \t\f\r\n,]*\\([^ \t\f\r\n,]+\\)") newsgroups (wl-delete-duplicates newsgroups) newsgroups @@ -387,24 +423,24 @@ Reply to author if WITH-ARG is non-nil." to (copy-sequence to)) t t)) (and to (setq to (mapconcat - '(lambda (addr) - (if wl-draft-reply-use-address-with-full-name - (or (cdr (assoc addr to-alist)) addr) - addr)) + (lambda (addr) + (if wl-draft-reply-use-address-with-full-name + (or (cdr (assoc addr to-alist)) addr) + addr)) to ",\n\t"))) (and cc (setq cc (mapconcat - '(lambda (addr) - (if wl-draft-reply-use-address-with-full-name - (or (cdr (assoc addr cc-alist)) addr) - addr)) + (lambda (addr) + (if wl-draft-reply-use-address-with-full-name + (or (cdr (assoc addr cc-alist)) addr) + addr)) cc ",\n\t"))) (and mail-followup-to (setq mail-followup-to (mapconcat - '(lambda (addr) - (if wl-draft-reply-use-address-with-full-name - (or (cdr (assoc addr (append to-alist cc-alist))) addr) - addr)) + (lambda (addr) + (if wl-draft-reply-use-address-with-full-name + (or (cdr (assoc addr (append to-alist cc-alist))) addr) + addr)) mail-followup-to ",\n\t"))) (and (null to) (setq to cc cc nil)) (setq references (delq nil references) @@ -413,18 +449,45 @@ Reply to author if WITH-ARG is non-nil." references (wl-delete-duplicates references) references (if references (mapconcat 'identity references "\n\t"))) - (wl-draft - to subject in-reply-to cc references newsgroups mail-followup-to - nil nil nil nil summary-buf nil parent-folder) - (setq wl-draft-reply-buffer buf)) - (run-hooks 'wl-reply-hook)) + (and wl-draft-use-frame + (get-buffer-window summary-buf) + (select-window (get-buffer-window summary-buf))) + (wl-draft (list (cons 'To to) + (cons 'Cc cc) + (cons 'Newsgroups newsgroups) + (cons 'Subject subject) + (cons 'In-Reply-To in-reply-to) + (cons 'References references) + (cons 'Mail-Followup-To mail-followup-to)) + nil nil nil nil parent-folder number) + (setq wl-draft-reply-buffer buf) + (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-reply-hook)) + +(defun wl-draft-reply-position (position) + (cond ((eq position 'body) + (wl-draft-body-goto-top)) + ((eq position 'bottom) + (wl-draft-body-goto-bottom)) + ((eq position 'top) + (goto-char (point-min))) + ((and (stringp position) + (std11-field-body position)) + (progn (mail-position-on-field position) + (wl-draft-beginning-of-line))) + ((listp position) + (while (car position) + (wl-draft-reply-position (car position)) + (setq position (cdr position)))))) (defun wl-draft-add-references () (wl-draft-add-in-reply-to "References")) (defun wl-draft-add-in-reply-to (&optional alt-field) - (let* ((mes-id (save-excursion - (set-buffer mail-reply-buffer) + (let* ((mes-id (with-current-buffer mail-reply-buffer (std11-field-body "message-id"))) (field (or alt-field "In-Reply-To")) (ref (std11-field-body field)) @@ -453,12 +516,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)) @@ -478,15 +542,6 @@ Reply to author if WITH-ARG is non-nil." (when wl-highlight-body-too (wl-highlight-body-region beg (point-max))))) -(defun wl-draft-confirm () - "Confirm send message." - (interactive) - (y-or-n-p (format "Send current draft as %s? " - (cond ((and (wl-message-mail-p) (wl-message-news-p)) - "Mail and News") - ((wl-message-mail-p) "Mail") - ((wl-message-news-p) "News"))))) - (defun wl-message-news-p () "If exist valid Newsgroups field, return non-nil." (std11-field-body "Newsgroups")) @@ -503,26 +558,17 @@ Reply to author if WITH-ARG is non-nil." (wl-message-field-exists-p "Resent-to") (wl-message-field-exists-p "Cc") (wl-message-field-exists-p "Bcc") + (wl-message-field-exists-p wl-draft-mime-bcc-field-name) ;;; This may be needed.. ;;; (wl-message-field-exists-p "Fcc") )) -(defun wl-draft-open-file (&optional file) - "Open FILE for edit." - (interactive) -;;;(interactive "*fFile to edit: ") - (wl-draft-edit-string (elmo-get-file-string - (or file - (read-file-name "File to edit: " - (or wl-temporary-file-directory - "~/")))))) - (defun wl-draft-edit-string (string) (let ((cur-buf (current-buffer)) (tmp-buf (get-buffer-create " *wl-draft-edit-string*")) to subject in-reply-to cc references newsgroups mail-followup-to content-type content-transfer-encoding from - body-beg buffer-read-only) + body-beg) (set-buffer tmp-buf) (erase-buffer) (insert string) @@ -561,19 +607,25 @@ Reply to author if WITH-ARG is non-nil." (search-forward (concat mail-header-separator "\n") nil t)) (unwind-protect (set-buffer - (wl-draft to subject in-reply-to cc references newsgroups - mail-followup-to + (wl-draft (list + (cons 'From + (if (wl-address-user-mail-address-p from) from)) + (cons 'To to) + (cons 'Cc cc) + (cons 'Subject subject) + (cons 'Newsgroups newsgroups) + (cons 'Mail-Followup-To mail-followup-to) + (cons 'In-Reply-To in-reply-to) + (cons 'References references)) content-type content-transfer-encoding (buffer-substring (point) (point-max)) - 'edit-again nil - (if (member (nth 1 (std11-extract-address-components from)) - wl-user-mail-address-list) - from))) - (and to (mail-position-on-field "To")) - (delete-other-windows) - (kill-buffer tmp-buf))) - (setq buffer-read-only nil) ;;?? - (run-hooks 'wl-draft-reedit-hook)) + 'edit-again)) + (kill-buffer tmp-buf)) + ;; Set cursor point to the top. + (goto-char (point-min)) + (search-forward (concat mail-header-separator "\n") nil t) + (run-hooks 'wl-draft-reedit-hook) + (and to (mail-position-on-field "To")))) (defun wl-draft-insert-current-message (dummy) (interactive) @@ -582,17 +634,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 @@ -601,7 +658,7 @@ Reply to author if WITH-ARG is non-nil." (wl-folder-get-entity-with-petname) wl-folder-entity-hashtb) nil nil wl-default-spec - 'wl-read-folder-hist)) + 'wl-read-folder-history)) (number (call-interactively (function (lambda (num) (interactive "nNumber: ") @@ -611,11 +668,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)))) @@ -625,33 +683,23 @@ Reply to author if WITH-ARG is non-nil." (defun wl-default-draft-cite () (let ((mail-yank-ignored-headers "[^:]+:") (mail-yank-prefix "> ") - (summary-buf wl-current-summary-buffer) - (message-buf (get-buffer (wl-current-message-buffer))) - from date cite-title num entity) - (if (and summary-buf - (buffer-live-p summary-buf) - message-buf - (buffer-live-p message-buf)) - (progn - (with-current-buffer summary-buf - (setq num (save-excursion - (set-buffer message-buf) - wl-message-buffer-cur-number)) - (setq entity (elmo-msgdb-overview-get-entity - num (wl-summary-buffer-msgdb))) - (setq date (elmo-msgdb-overview-entity-get-date entity)) - (setq from (elmo-msgdb-overview-entity-get-from entity))) - (setq cite-title (format "At %s,\n%s wrote:" - (or date "some time ago") - (if wl-default-draft-cite-decorate-author - (wl-summary-from-func-internal - (or from "you")) - (or from "you")))))) - (and cite-title - (insert cite-title "\n")) + date from cite-title) + (save-restriction + (if (< (mark t) (point)) + (exchange-point-and-mark)) + (narrow-to-region (point)(point-max)) + (setq date (std11-field-body "date") + from (std11-field-body "from"))) + (when (or date from) + (insert (format "At %s,\n%s wrote:\n" + (or date "some time ago") + (if wl-default-draft-cite-decorate-author + (funcall wl-summary-from-function + (or from "you")) + (or from "you"))))) (mail-indent-citation))) -(defvar wl-draft-buffer nil "Draft buffer to yank content") +(defvar wl-draft-buffer nil "Draft buffer to yank content.") (defun wl-draft-yank-to-draft-buffer (buffer) "Yank BUFFER content to `wl-draft-buffer'." (set-buffer wl-draft-buffer) @@ -663,19 +711,22 @@ Reply to author if WITH-ARG is non-nil." "Yank original message." (interactive "P") (if arg - (let (buf mail-reply-buffer) - (elmo-set-work-buf - (yank) - (setq buf (current-buffer))) - (setq mail-reply-buffer buf) - (wl-draft-yank-from-mail-reply-buffer nil)) + (let ((draft-buffer (current-buffer)) + mail-reply-buffer) + (with-temp-buffer + (insert "\n") + (yank) + (setq mail-reply-buffer (current-buffer)) + (with-current-buffer draft-buffer + (wl-draft-yank-from-mail-reply-buffer nil)))) (wl-draft-yank-current-message-entity))) (defun wl-draft-hide (editing-buffer) "Hide the editing draft buffer if possible." (when (and editing-buffer - (buffer-live-p editing-buffer)) - (set-buffer editing-buffer) + (buffer-live-p editing-buffer) + (get-buffer-window editing-buffer)) + (select-window (get-buffer-window editing-buffer)) (let ((sum-buf wl-draft-buffer-cur-summary-buffer) fld-buf sum-win fld-win) (if (and wl-draft-use-frame @@ -684,38 +735,34 @@ Reply to author if WITH-ARG is non-nil." (delete-frame) ;; hide draft window (or (one-window-p) - (delete-window))) - ;; stay folder window if required - (when wl-stay-folder-window - (if (setq fld-buf (get-buffer wl-folder-buffer-name)) - (if (setq fld-win (get-buffer-window fld-buf)) - (select-window fld-win) - (if wl-draft-resume-folder-window ;; resume folder window - (switch-to-buffer fld-buf))))) - (if (buffer-live-p sum-buf) - (if (setq sum-win (get-buffer-window sum-buf t)) - ;; if Summary is on the frame, select it. - (select-window sum-win) - ;; if summary is not on the frame, switch to it. - (if (and wl-stay-folder-window - (or wl-draft-resume-folder-window fld-win)) - (wl-folder-select-buffer sum-buf) - (switch-to-buffer sum-buf))))))) + (delete-window)) + ;; stay folder window if required + (when wl-stay-folder-window + (if (setq fld-buf (get-buffer wl-folder-buffer-name)) + (if (setq fld-win (get-buffer-window fld-buf)) + (select-window fld-win) + (if wl-draft-resume-folder-window ;; resume folder window + (switch-to-buffer fld-buf))))) + (if (buffer-live-p sum-buf) + (if (setq sum-win (get-buffer-window sum-buf t)) + ;; if Summary is on the frame, select it. + (select-window sum-win) + ;; if summary is not on the frame, switch to it. + (if (and wl-stay-folder-window + (or wl-draft-resume-folder-window fld-win)) + (wl-folder-select-buffer sum-buf) + (switch-to-buffer sum-buf)))))))) (defun wl-draft-delete (editing-buffer) - "kill the editing draft buffer and delete the file corresponds to it." - (save-excursion - (when editing-buffer - (set-buffer editing-buffer) - (if wl-draft-buffer-file-name - (progn - (if (file-exists-p wl-draft-buffer-file-name) - (delete-file wl-draft-buffer-file-name)) - (let ((msg (and wl-draft-buffer-file-name - (string-match "[0-9]+$" wl-draft-buffer-file-name) - (string-to-int - (match-string 0 wl-draft-buffer-file-name))))) - (wl-draft-config-info-operation msg 'delete)))) + "Kill the editing draft buffer and delete the file corresponds to it." + (when editing-buffer + (with-current-buffer editing-buffer + (when wl-draft-buffer-message-number + (elmo-folder-delete-messages (wl-draft-get-folder) + (list + wl-draft-buffer-message-number)) + (wl-draft-config-info-operation wl-draft-buffer-message-number + 'delete)) (set-buffer-modified-p nil) ; force kill (kill-buffer editing-buffer)))) @@ -726,8 +773,9 @@ Reply to author if WITH-ARG is non-nil." (when (and (or (eq major-mode 'wl-draft-mode) (eq major-mode 'mail-mode)) (or force-kill - (y-or-n-p "Kill Current Draft? "))) + (yes-or-no-p "Kill Current Draft? "))) (let ((cur-buf (current-buffer))) + (run-hooks 'wl-draft-kill-pre-hook) (wl-draft-hide cur-buf) (wl-draft-delete cur-buf))) (message ""))) @@ -748,19 +796,46 @@ text was killed." (kill-region b e) (insert wl-draft-elide-ellipsis)) +;; Imported from message.el. +(defun wl-draft-beginning-of-line (&optional n) + "Move point to beginning of header value or to beginning of line." + (interactive "p") + (let ((zrs 'zmacs-region-stays)) + (when (and (interactive-p) (boundp zrs)) + (set zrs t))) + (if (wl-draft-point-in-header-p) + (let* ((here (point)) + (bol (progn (beginning-of-line n) (point))) + (eol (line-end-position)) + (eoh (and (looking-at "[^ \t]") + (re-search-forward ": *" eol t)))) + (if (and eoh (or (> here eoh) (= here bol))) + (goto-char eoh) + (goto-char bol))) + (beginning-of-line n))) + +(defun wl-draft-point-in-header-p () + "Return t if point is in the header." + (save-excursion + (let ((p (point))) + (goto-char (point-min)) + (not (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "\n") + p t))))) + ;; function for wl-sent-message-via (defmacro wl-draft-sent-message-p (type) - (` (eq (nth 1 (assq (, type) wl-sent-message-via)) 'sent))) + `(eq (nth 1 (assq ,type wl-sent-message-via)) 'sent)) (defmacro wl-draft-set-sent-message (type result &optional server-port) - (` (let ((element (assq (, type) wl-sent-message-via))) - (if element - (unless (eq (nth 1 element) (, result)) - (setcdr element (list (, result) (, server-port))) - (setq wl-sent-message-modified t)) - (push (list (, type) (, result) (, server-port)) wl-sent-message-via) - (setq wl-sent-message-modified t))))) + `(let ((element (assq ,type wl-sent-message-via))) + (if element + (unless (eq (nth 1 element) ,result) + (setcdr element (list ,result ,server-port)) + (setq wl-sent-message-modified t)) + (push (list ,type ,result ,server-port) wl-sent-message-via) + (setq wl-sent-message-modified t)))) (defun wl-draft-sent-message-results () (let ((results wl-sent-message-via) @@ -790,11 +865,11 @@ text was killed." (concat " to=" (mapconcat 'identity - (mapcar '(lambda(x) (format "<%s>" x)) to) + (mapcar (lambda (x) (format "<%s>" x)) to) ",")))) "")) (id (if id (concat " id=" id) "")) - (time (wl-sendlog-time))) + (time (format-time-string "%Y/%m/%d %T"))) (insert (format "%s proto=%s stat=%s%s%s%s\n" time proto status server to id)) (if (and wl-draft-sendlog-max-size filesize @@ -853,8 +928,21 @@ to find out how to use this." msg-id-list)))) (nreverse msg-id-list))) +(defun wl-draft-eword-encode-address-list (string &optional column) + "Encode header field STRING as list of address, and return the result. +Cause an error when STRING contains invalid address. +Optional argument COLUMN is start-position of the field." + (car (eword-encode-rword-list + (or column eword-encode-default-start-column) + (eword-encode-addresses-to-rword-list + (wl-draft-std11-parse-addresses (std11-lexical-analyze string)))))) + (defun wl-draft-std11-parse-addresses (lal) (let ((ret (std11-parse-address lal))) + (when (and (not (and (eq (length lal) 1) + (eq (car (car lal)) 'spaces))) + (null ret)) + (error "Error while parsing address")) (if ret (let ((dest (list (car ret)))) (setq lal (cdr ret)) @@ -916,7 +1004,10 @@ from current buffer." "Get address list suitable for smtp RCPT TO:
. Group list content is removed if `wl-draft-remove-group-list-contents' is non-nil." - (let ((fields '("to" "cc" "bcc")) + (let ((fields (if (and wl-draft-doing-mime-bcc + wl-draft-disable-bcc-for-mime-bcc) + '("to" "cc") + '("to" "cc" "bcc"))) (resent-fields '("resent-to" "resent-cc" "resent-bcc")) (case-fold-search t) addrs recipients) @@ -956,18 +1047,7 @@ non-nil." "$\\|^$") nil t) (point-marker))) (smtp-server - (or wl-smtp-posting-server - ;; Compatibility stuff for FLIM 1.12.5 or earlier. - ;; They don't accept a function as the value of `smtp-server'. - (if (functionp smtp-server) - (funcall - smtp-server - sender - ;; no harm.. - (let (wl-draft-remove-group-list-contents) - (wl-draft-deduce-address-list - (current-buffer) (point-min) delimline))) - (or smtp-server "localhost")))) + (or wl-smtp-posting-server smtp-server "localhost")) (smtp-service (or wl-smtp-posting-port smtp-service)) (smtp-local-domain (or smtp-local-domain wl-local-domain)) (id (std11-field-body "message-id")) @@ -988,8 +1068,7 @@ non-nil." (newline)) (run-hooks 'wl-mail-send-pre-hook) ;; X-PGP-Sig, Cancel-Lock (if mail-interactive - (save-excursion - (set-buffer errbuf) + (with-current-buffer errbuf (erase-buffer))) (wl-draft-delete-field "bcc" delimline) (wl-draft-delete-field "resent-bcc" delimline) @@ -1002,12 +1081,17 @@ non-nil." (error (wl-draft-write-sendlog 'failed 'smtp smtp-server recipients id) - (if (/= (nth 1 err) 334) + (if (and (eq (car err) 'smtp-response-error) + (= (nth 1 err) 535)) (elmo-remove-passwd (wl-smtp-password-key smtp-sasl-user-name (car smtp-sasl-mechanisms) smtp-server))) + (signal (car err) (cdr err))) + (quit + (wl-draft-write-sendlog 'uncertain 'smtp smtp-server + recipients id) (signal (car err) (cdr err))))) (wl-draft-set-sent-message 'mail 'sent) (wl-draft-write-sendlog @@ -1018,7 +1102,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 @@ -1029,20 +1113,22 @@ 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) - (signal (car error)(cdr error))))) + (unless (string= (nth 1 error) "Unplugged") + (signal (car error) (cdr error)))))) (wl-draft-send-mail-with-smtp)) (defun wl-draft-insert-required-fields (&optional force-msgid) "Insert Message-ID, Date, and From field. -If FORCE-MSGID, ignore 'wl-insert-message-id'." +If FORCE-MSGID, insert message-id regardless of `wl-insert-message-id'." ;; Insert Message-Id field... (goto-char (point-min)) (when (and (or force-msgid @@ -1063,16 +1149,25 @@ If FORCE-MSGID, ignore 'wl-insert-message-id'." (defun wl-draft-normal-send-func (editing-buffer kill-when-done) "Send the message in the current buffer." (save-restriction - (std11-narrow-to-header mail-header-separator) + (narrow-to-region (goto-char (point-min)) + (if (re-search-forward + (concat + "^" (regexp-quote mail-header-separator) "$") + nil t) + (match-beginning 0) + (point-max))) (wl-draft-insert-required-fields) - ;; Delete null fields. - (goto-char (point-min)) - (while (re-search-forward "^[^ \t\n:]+:[ \t]*\n" nil t) - (replace-match "")) ;; ignore any blank lines in the header - (while (re-search-forward "\n\n\n*" nil t) - (replace-match "\n"))) -;;; (run-hooks 'wl-mail-send-pre-hook) ;; X-PGP-Sig, Cancel-Lock + (while (progn (goto-char (point-min)) + (re-search-forward "\n[ \t]*\n\n*" nil t)) + (replace-match "\n")) + (goto-char (point-min)) + (while (re-search-forward + "^[^ \t\n:]+:[ \t]*\\(.*\\(\n[ \t].*\\)*\\)\n" + nil t) + (when (string= "" (match-string 1)) + (replace-match "")))) +;;; (run-hooks 'wl-mail-send-pre-hook) ; X-PGP-Sig, Cancel-Lock (wl-draft-dispatch-message) (when kill-when-done ;; hide editing-buffer. @@ -1082,9 +1177,9 @@ If FORCE-MSGID, ignore 'wl-insert-message-id'." (defun wl-draft-dispatch-message (&optional mes-string) "Send the message in the current buffer. Not modified the header fields." - (let (delimline) + (let (delimline mime-bcc) (if (and wl-draft-verbose-send mes-string) - (message mes-string)) + (message "%s" mes-string)) ;; get fcc folders. (setq delimline (wl-draft-get-header-delimiter t)) (unless wl-draft-fcc-list @@ -1098,7 +1193,11 @@ If FORCE-MSGID, ignore 'wl-insert-message-id'." (if (or (not (or wl-draft-force-queuing wl-draft-force-queuing-mail)) (memq 'mail wl-sent-message-queued)) - (funcall wl-draft-send-mail-function) + (progn + (setq mime-bcc (wl-draft-mime-bcc-field)) + (funcall wl-draft-send-mail-function) + (when (not (zerop (length mime-bcc))) + (wl-draft-do-mime-bcc mime-bcc))) (push 'mail wl-sent-message-queued) (wl-draft-set-sent-message 'mail 'unplugged))) (if (and (wl-message-news-p) @@ -1110,14 +1209,14 @@ If FORCE-MSGID, ignore 'wl-insert-message-id'." (funcall wl-draft-send-news-function) (push 'news wl-sent-message-queued) (wl-draft-set-sent-message 'news 'unplugged)))) - ;; (let* ((status (wl-draft-sent-message-results)) (unplugged-via (car status)) (sent-via (nth 1 status))) ;; If one sent, process fcc folder. (if (and sent-via wl-draft-fcc-list) (progn - (wl-draft-do-fcc (wl-draft-get-header-delimiter) wl-draft-fcc-list) + (wl-draft-do-fcc (wl-draft-get-header-delimiter) + wl-draft-fcc-list) (setq wl-draft-fcc-list nil))) (if wl-draft-use-cache (let ((id (std11-field-body "Message-ID")) @@ -1138,10 +1237,11 @@ If FORCE-MSGID, ignore 'wl-insert-message-id'." (setq wl-draft-verbose-msg (format "Sending%s and Queuing%s..." sent-via unplugged-via)) - (message (concat wl-draft-verbose-msg "done"))) + (message "%sdone" wl-draft-verbose-msg)) (if mes-string - (message (concat mes-string - (if sent-via "done" "failed"))))))))) + (message "%s%s" + mes-string + (if sent-via "done" "failed")))))))) (not wl-sent-message-modified)) ;; return value (defun wl-draft-raw-send (&optional kill-when-done force-pre-hook mes-string) @@ -1168,33 +1268,85 @@ If FORCE-MSGID, ignore 'wl-insert-message-id'." (setq locals (cdr locals))) result)) +(defcustom wl-draft-send-confirm-with-preview t + "*Non-nil to invoke preview through confirmation of sending. +This variable is valid when `wl-interactive-send' has non-nil value." + :type 'boolean + :group 'wl-draft) + +(defun wl-draft-send-confirm () + (unwind-protect + (condition-case nil + (progn + (when wl-draft-send-confirm-with-preview + (let (wl-draft-send-hook + (pgg-decrypt-automatically nil)) + (wl-draft-preview-message))) + (save-excursion + (goto-char (point-min)) ; to show recipients in header + (funcall + (if (functionp wl-draft-send-confirm-type) + wl-draft-send-confirm-type + (lambda (prompt) + (wl-y-or-n-p-with-scroll + prompt + (eq wl-draft-send-confirm-type 'scroll-by-SPC/BS)))) + "Send current draft? "))) + (quit nil)) + (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. If KILL-WHEN-DONE is non-nil, current draft buffer is killed" (interactive) - ;; Don't call this explicitly. - ;; Added to 'wl-draft-send-hook (by teranisi) - ;; (wl-draft-config-exec) +;;; Don't call this explicitly. +;;; Added to 'wl-draft-send-hook (by teranisi) +;;; (wl-draft-config-exec) (run-hooks 'wl-draft-send-hook) (when (or (not wl-interactive-send) - (y-or-n-p "Do you really want to send current draft? ")) + (wl-draft-send-confirm)) (let ((send-mail-function 'wl-draft-raw-send) (editing-buffer (current-buffer)) (sending-buffer (wl-draft-generate-clone-buffer " *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 - (save-excursion (set-buffer sending-buffer) + (with-current-buffer sending-buffer (if (and (not (wl-message-mail-p)) (not (wl-message-news-p))) (error "No recipient is specified")) - (expand-abbrev) ; for mail-abbrevs - (run-hooks 'mail-send-hook) ; translate buffer + (expand-abbrev) ; for mail-abbrevs + (let ((mime-header-encode-method-alist + (append + '((wl-draft-eword-encode-address-list + . (To Cc Bcc Resent-To Resent-Cc Resent-Bcc From))) + (if (boundp 'mime-header-encode-method-alist) + (symbol-value 'mime-header-encode-method-alist))))) + (run-hooks 'mail-send-hook) ; translate buffer + ) + ;; (if wl-draft-verbose-send - (message (or mes-string "Sending..."))) + (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))) + (condition-case nil + (wl-folder-set-persistent-mark + parent-folder parent-number parent-flag) + (error + (message "Set mark (%s) failed" (symbol-name parent-flag))))) (funcall wl-draft-send-function editing-buffer kill-when-done) ;; Now perform actions on successful sending. (while mail-send-actions @@ -1203,48 +1355,100 @@ If KILL-WHEN-DONE is non-nil, current draft buffer is killed" (cdr (car mail-send-actions))) (error)) (setq mail-send-actions (cdr mail-send-actions))) -;; (if (or (eq major-mode 'wl-draft-mode) -;; (eq major-mode 'mail-mode)) -;; (local-set-key "\C-c\C-s" 'wl-draft-send)) ; override (if wl-draft-verbose-send - (message (concat (or wl-draft-verbose-msg - mes-string "Sending...") - "done")))) + (message "%sdone" + (or wl-draft-verbose-msg + mes-string + "Sending...")))) ;; kill sending buffer, anyway. (and (buffer-live-p sending-buffer) (kill-buffer sending-buffer)))))) +(defun wl-draft-mime-bcc-field () + "Return the MIME-Bcc field body. The field is deleted." + (prog1 (std11-field-body wl-draft-mime-bcc-field-name) + (wl-draft-delete-field wl-draft-mime-bcc-field-name))) + +(defun wl-draft-do-mime-bcc (field-body) + "Send MIME-Bcc (Encapsulated blind carbon copy)." + (let ((orig-from (mime-decode-field-body (std11-field-body "from") + 'From)) + (orig-subj (mime-decode-field-body (or (std11-field-body "subject") + "") + 'Subject)) + (recipients (wl-parse-addresses field-body)) + (draft-buffer (current-buffer)) + wl-draft-use-frame) + (save-window-excursion + (when (and (not wl-draft-doing-mime-bcc) ; To avoid infinite loop. + (not (zerop (length field-body)))) + (let ((wl-draft-doing-mime-bcc t)) + (dolist (recipient recipients) + (wl-draft-create-buffer) + (wl-draft-create-contents + (append `((From . ,orig-from) + (To . ,recipient) + (Subject . ,(concat "A blind carbon copy (" + orig-subj + ")"))) + (wl-draft-default-headers))) + (wl-draft-insert-mail-header-separator) + (wl-draft-prepare-edit) + (goto-char (point-max)) + (insert (or wl-draft-mime-bcc-body + "This is a blind carbon copy.") + "\n") + (mime-edit-insert-tag "message" "rfc822") + (insert-buffer-substring draft-buffer) + (let (wl-interactive-send) + (wl-draft-send 'kill-when-done)))))))) + (defun wl-draft-save () - "Save current draft. -Derived from `message-save-drafts' in T-gnus." + "Save current draft." (interactive) (if (buffer-modified-p) (progn - (message "Saving %s..." wl-draft-buffer-file-name) - (let ((msg (buffer-substring-no-properties (point-min) (point-max)))) - (with-temp-file wl-draft-buffer-file-name + (message "Saving...") + (let ((msg (buffer-substring-no-properties (point-min) (point-max))) + next-number) + (when wl-draft-buffer-message-number + (elmo-folder-delete-messages (wl-draft-get-folder) + (list wl-draft-buffer-message-number)) + (wl-draft-config-info-operation wl-draft-buffer-message-number + 'delete)) + (elmo-folder-check (wl-draft-get-folder)) + ;; If no header separator, insert it. + (with-temp-buffer (insert msg) - ;; If no header separator, insert it. - (save-excursion + (goto-char (point-min)) + (unless (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "$") + nil t) (goto-char (point-min)) - (unless (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "$") - nil t) - (goto-char (point-min)) - (if (re-search-forward "\n\n" nil t) - (replace-match (concat "\n" mail-header-separator "\n")) - (goto-char (point-max)) - (insert (if (eq (char-before) ?\n) "" "\n") - mail-header-separator "\n")))) - (mime-edit-translate-buffer) - (wl-draft-get-header-delimiter t))) - (set-buffer-modified-p nil) - (wl-draft-config-info-operation - (and (string-match "[0-9]+$" wl-draft-buffer-file-name) - (string-to-int - (match-string 0 wl-draft-buffer-file-name))) - 'save) - (message "Saving %s...done" wl-draft-buffer-file-name)) + (if (re-search-forward "\n\n" nil t) + (replace-match (concat "\n" mail-header-separator "\n")) + (goto-char (point-max)) + (insert (if (eq (char-before) ?\n) "" "\n") + mail-header-separator "\n"))) + (let ((mime-header-encode-method-alist + (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 + (elmo-folder-next-message-number (wl-draft-get-folder))) + (elmo-folder-append-buffer (wl-draft-get-folder))) + (elmo-folder-check (wl-draft-get-folder)) + (elmo-folder-commit (wl-draft-get-folder)) + (setq wl-draft-buffer-message-number next-number) + (rename-buffer (format "%s/%d" wl-draft-folder next-number) t) + (setq buffer-file-name (buffer-name)) + (set-buffer-modified-p nil) + (wl-draft-config-info-operation wl-draft-buffer-message-number 'save) + (message "Saving...done"))) (message "(No changes need to be saved)"))) (defun wl-draft-mimic-kill-buffer () @@ -1256,7 +1460,13 @@ Derived from `message-save-drafts' in T-gnus." (if (or (not bufname) (string-equal bufname "") (string-equal bufname (buffer-name))) - (wl-draft-save-and-exit) + (let ((bufname (current-buffer))) + (when (or (not (buffer-modified-p)) + (yes-or-no-p + (format "Buffer %s modified; kill anyway? " bufname))) + (set-buffer-modified-p nil) + (wl-draft-hide bufname) + (kill-buffer bufname))) (kill-buffer bufname)))) (defun wl-draft-save-and-exit () @@ -1309,38 +1519,48 @@ Derived from `message-save-drafts' in T-gnus." (point-max))))))) (defun wl-draft-get-fcc-list (header-end) - (let (fcc-list - (case-fold-search t)) - (or (markerp header-end) (error "HEADER-END must be a marker")) - (save-excursion - (goto-char (point-min)) - (while (re-search-forward "^Fcc:[ \t]*" header-end t) - (setq fcc-list - (cons (buffer-substring-no-properties - (point) - (progn - (end-of-line) - (skip-chars-backward " \t") - (point))) - fcc-list)) - (save-match-data - (wl-folder-confirm-existence - (wl-folder-get-elmo-folder (eword-decode-string (car fcc-list))))) - (delete-region (match-beginning 0) - (progn (forward-line 1) (point))))) - fcc-list)) + (if (and wl-draft-doing-mime-bcc + wl-draft-disable-fcc-for-mime-bcc) + (progn + (wl-draft-delete-field "fcc") + nil) + (let (fcc-list + (case-fold-search t)) + (or (markerp header-end) (error "HEADER-END must be a marker")) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward "^Fcc:[ \t]*" header-end t) + (save-match-data + (setq fcc-list + (append fcc-list + (split-string + (buffer-substring-no-properties + (point) + (progn + (end-of-line) + (skip-chars-backward " \t") + (point))) + ",[ \t]*"))) + (dolist (folder fcc-list) + (wl-folder-confirm-existence + (wl-folder-get-elmo-folder (eword-decode-string folder))))) + (delete-region (match-beginning 0) + (progn (forward-line 1) (point))))) + fcc-list))) + +(defcustom wl-draft-fcc-append-read-folder-history t + "Non-nil to append fcc'ed folder to `wl-read-folder-history'." + :type 'boolean + :group 'wl-draft) (defun wl-draft-do-fcc (header-end &optional fcc-list) (let ((send-mail-buffer (current-buffer)) - (tembuf (generate-new-buffer " fcc output")) (case-fold-search t) beg end) (or (markerp header-end) (error "HEADER-END must be a marker")) - (save-excursion - (unless fcc-list - (setq fcc-list (wl-draft-get-fcc-list header-end))) - (set-buffer tembuf) - (erase-buffer) + (unless fcc-list + (setq fcc-list (wl-draft-get-fcc-list header-end))) + (with-temp-buffer ;; insert just the headers to avoid moving the gap more than ;; necessary (the message body could be arbitrarily huge.) (insert-buffer-substring send-mail-buffer 1 header-end) @@ -1348,22 +1568,20 @@ Derived from `message-save-drafts' in T-gnus." (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))) - (not wl-fcc-force-as-read)) + (and wl-fcc-force-as-read '(read))) (wl-draft-write-sendlog 'ok 'fcc nil (car fcc-list) id) (wl-draft-write-sendlog 'failed 'fcc nil (car fcc-list) id)) - (setq fcc-list (cdr fcc-list))))) - (kill-buffer tembuf))) + (if (and wl-draft-fcc-append-read-folder-history + (boundp 'wl-read-folder-history)) + (or (equal (car fcc-list) (car wl-read-folder-history)) + (setq wl-read-folder-history + (append (list (car fcc-list)) wl-read-folder-history)))) + (setq fcc-list (cdr fcc-list))))))) (defun wl-draft-on-field-p () (if (< (point) @@ -1386,16 +1604,13 @@ Derived from `message-save-drafts' in T-gnus." nil (if (re-search-forward ":" pos t) nil t))))))) -(defun wl-draft-random-alphabet () - (let ((alphabet '(?A ?B ?C ?D ?E ?F ?G ?H ?I ?J ?K ?L ?M ?N ?O ?P ?Q ?R ?S ?T ?U ?V ?W ?X ?Y ?Z))) - (nth (abs (% (random) 26)) alphabet))) - ;;;;;;;;;;;;;;;; ;;;###autoload -(defun wl-draft (&optional to subject in-reply-to cc references newsgroups - mail-followup-to +(defun wl-draft (&optional header-alist content-type content-transfer-encoding - body edit-again summary-buf from parent-folder) + body edit-again + parent-folder + parent-number) "Write and send mail/news message with Wanderlust." (interactive) (require 'wl) @@ -1407,31 +1622,31 @@ Derived from `message-save-drafts' in T-gnus." (let (wl-demo) (wl-init)) ; returns immediately if already initialized. - (let (buf-name header-alist) - (setq buf-name - (wl-draft-create-buffer - (or - (eq this-command 'wl-draft) - (eq this-command 'wl-summary-write) - (eq this-command 'wl-summary-write-current-folder)) - parent-folder summary-buf)) - (setq header-alist - (list - (cons "From: " (or from wl-from)) - (cons "To: " (or to - (and - (or (interactive-p) - (eq this-command 'wl-summary-write)) - ""))) - (cons "Cc: " cc) - (cons "Subject: " (or subject "")) - (cons "Newsgroups: " newsgroups) - (cons "Mail-Followup-To: " mail-followup-to) - (cons "In-Reply-To: " in-reply-to) - (cons "References: " references))) + (wl-start-save-drafts) + (let (buffer header-alist-internal) + (setq buffer (wl-draft-create-buffer parent-folder parent-number)) + (unless (cdr (assq 'From header-alist)) + (setq header-alist + (append (list (cons 'From wl-from)) header-alist))) + (unless (cdr (assq 'To header-alist)) + (let ((to)) + (when (setq to (and + (interactive-p) + "")) + (if (assq 'To header-alist) + (setcdr (assq 'To header-alist) to) + (setq header-alist + (append header-alist + (list (cons 'To to)))))))) + (unless (cdr (assq 'Subject header-alist)) + (if (assq 'Subject header-alist) + (setcdr (assq 'Subject header-alist) "") + (setq header-alist + (append header-alist (list (cons 'Subject "")))))) (setq header-alist (append header-alist (wl-draft-default-headers) - (if body (list "" body)))) + wl-draft-additional-header-alist + (if body (list "" (cons 'Body body))))) (wl-draft-create-contents header-alist) (if edit-again (wl-draft-decode-body @@ -1440,72 +1655,89 @@ Derived from `message-save-drafts' in T-gnus." (wl-draft-prepare-edit) (if (interactive-p) (run-hooks 'wl-mail-setup-hook)) - (goto-char (point-min)) + (setq buffer-undo-list nil) (wl-user-agent-compose-internal) ;; user-agent - (cond ((eq this-command 'wl-summary-write-current-newsgroup) - (mail-position-on-field "Subject")) - ((and (interactive-p) (null to)) + (cond ((and + (interactive-p) + (string= (cdr (assq 'To header-alist)) "")) (mail-position-on-field "To")) (t (goto-char (point-max)))) - buf-name)) - -(defun wl-draft-create-buffer (&optional full parent-folder summary-buf) - (let* ((draft-folder (wl-folder-get-elmo-folder wl-draft-folder)) - (parent-folder (or parent-folder (wl-summary-buffer-folder-name))) - (summary-buf (or summary-buf (wl-summary-get-buffer parent-folder))) - buf-name file-name num change-major-mode-hook) - (if (not (elmo-folder-message-file-p draft-folder)) - (error "%s folder cannot be used for draft folder" wl-draft-folder)) - (setq num (elmo-max-of-list - (or (elmo-folder-list-messages draft-folder) '(0)))) - (setq num (+ 1 num)) - ;; To get unused buffer name. - (while (get-buffer (concat wl-draft-folder "/" (int-to-string num))) - (setq num (+ 1 num))) - (setq buf-name (find-file-noselect - (setq file-name - (elmo-message-file-name - (wl-folder-get-elmo-folder wl-draft-folder) - num)))) + buffer)) + +(defun wl-draft-create-buffer (&optional parent-folder parent-number) + (let* ((draft-folder (wl-draft-get-folder)) + (reply-or-forward + (or (eq this-command 'wl-summary-reply) + (eq this-command 'wl-summary-reply-with-citation) + (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. + (set-buffer buffer) + ;; switch-buffer according to draft buffer style. (if wl-draft-use-frame - (switch-to-buffer-other-frame buf-name) - (switch-to-buffer buf-name)) - (set-buffer buf-name) - (if (not (string-match (regexp-quote wl-draft-folder) - (buffer-name))) - (rename-buffer (concat wl-draft-folder "/" (int-to-string num)))) - (if (or (eq wl-draft-reply-buffer-style 'full) - full) - (delete-other-windows)) + (switch-to-buffer-other-frame buffer) + (if reply-or-forward + (case wl-draft-reply-buffer-style + (split + (split-window-vertically) + (other-window 1) + (switch-to-buffer buffer)) + (keep + (switch-to-buffer buffer)) + (full + (delete-other-windows) + (switch-to-buffer buffer)) + (t + (if (functionp wl-draft-reply-buffer-style) + (funcall wl-draft-reply-buffer-style buffer) + (error "Invalid value for wl-draft-reply-buffer-style")))) + (case wl-draft-buffer-style + (split + (when (eq major-mode 'wl-summary-mode) + (wl-summary-toggle-disp-msg 'off)) + (split-window-vertically) + (other-window 1) + (switch-to-buffer buffer)) + (keep + (switch-to-buffer buffer)) + (full + (delete-other-windows) + (switch-to-buffer buffer)) + (t (if (functionp wl-draft-buffer-style) + (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) - ;; Don't care about supersession. - (setq buffer-file-name nil) (setq wl-sent-message-via nil) (setq wl-sent-message-queued nil) - (setq wl-draft-buffer-file-name file-name) (setq wl-draft-config-exec-flag t) - (setq wl-draft-parent-folder parent-folder) - (setq wl-draft-buffer-cur-summary-buffer summary-buf) - buf-name)) + (setq wl-draft-parent-folder (or parent-folder "")) + (setq wl-draft-parent-number parent-number) + (or (eq this-command 'wl-folder-write-current-folder) + (setq wl-draft-buffer-cur-summary-buffer + (wl-summary-get-buffer parent-folder))) + buffer)) (defun wl-draft-create-contents (header-alist) "header-alist' sample '(function ;; funcall string ;; insert string - (string . string) ;; insert string string - (string . function) ;; insert string (funcall) - (string . nil) ;; insert nothing - (function . (arg1 arg2 ..)) ;; call function with argument - nil ;; insert nothing -" + (symbol . string) ;; insert symbol-value: string + (symbol . function) ;; (funcall) and if it returns string, + ;; insert symbol-value: string + (symbol . nil) ;; do nothing + nil ;; do nothing + )" (unless (eq major-mode 'wl-draft-mode) - (error "wl-draft-create-header must be use in wl-draft-mode.")) + (error "`wl-draft-create-header' must be use in wl-draft-mode")) (let ((halist header-alist) field value) (while halist @@ -1519,11 +1751,15 @@ Derived from `message-save-drafts' in T-gnus." (setq field (car (car halist))) (setq value (cdr (car halist))) (cond - ((functionp field) (apply field value)) - ((stringp field) + ((symbolp field) (cond - ((stringp value) (insert field value "\n")) - ((functionp value) (insert field (funcall value) "\n")) + ((eq field 'Body) ; body + (insert value)) + ((stringp value) (insert (symbol-name field) ": " value "\n")) + ((functionp value) + (let ((value-return (funcall value))) + (when (stringp value-return) + (insert (symbol-name field) ": " value-return "\n")))) ((not value)) (t (debug)))) @@ -1536,12 +1772,26 @@ Derived from `message-save-drafts' in T-gnus." (defun wl-draft-prepare-edit () (unless (eq major-mode 'wl-draft-mode) - (error "wl-draft-create-header must be use in wl-draft-mode.")) + (error "`wl-draft-create-header' must be use in wl-draft-mode")) (let (change-major-mode-hook) (wl-draft-editor-mode) + (static-when (boundp 'auto-save-file-name-transforms) + (make-local-variable 'auto-save-file-name-transforms) + (setq auto-save-file-name-transforms + (cons (list (concat (regexp-quote wl-draft-folder) + "/\\([0-9]+\\)") + (concat (expand-file-name + "auto-save-" + (elmo-folder-msgdb-path + (wl-draft-get-folder))) + "\\1")) + auto-save-file-name-transforms))) + (when wl-draft-write-file-function + (add-hook 'local-write-file-hooks wl-draft-write-file-function)) (wl-draft-overload-functions) (wl-highlight-headers 'for-draft) - (wl-draft-save))) + (wl-draft-save) + (clear-visited-file-modtime))) (defun wl-draft-decode-header () (save-excursion @@ -1583,7 +1833,7 @@ Derived from `message-save-drafts' in T-gnus." (if (not (= (preceding-char) ?\n)) (insert ?\n))) -(defsubst wl-draft-insert-ccs (str cc) +(defsubst wl-draft-trim-ccs (cc) (let ((field (if (functionp cc) (funcall cc) @@ -1596,29 +1846,30 @@ Derived from `message-save-drafts' in T-gnus." (wl-parse-addresses (std11-field-body "To")) (wl-parse-addresses (std11-field-body "Cc")))) (mapcar 'downcase wl-subscribed-mailing-list))))) - (insert str field "\n")))) + field + nil))) -(defsubst wl-draft-default-headers () +(defun wl-draft-default-headers () (list - (cons "Mail-Reply-To: " (and wl-insert-mail-reply-to - (wl-address-header-extract-address - wl-from))) - (cons "" wl-generate-mailer-string-function) - (cons "Reply-To: " mail-default-reply-to) - (cons 'wl-draft-insert-ccs - (list "Bcc: " (or wl-bcc - (and mail-self-blind (user-login-name))))) - (cons 'wl-draft-insert-ccs - (list "Fcc: " wl-fcc)) - (cons "Organization: " wl-organization) + (cons 'Mail-Reply-To (and wl-insert-mail-reply-to + (wl-address-header-extract-address + wl-from))) + (cons 'User-Agent wl-generate-mailer-string-function) + (cons 'Reply-To mail-default-reply-to) + (cons 'Bcc (function + (lambda () + (wl-draft-trim-ccs + (or wl-bcc (and mail-self-blind (user-login-name))))))) + (cons 'Fcc (function + (lambda () + (wl-draft-trim-ccs wl-fcc)))) + (cons 'Organization wl-organization) (and wl-auto-insert-x-face (file-exists-p wl-x-face-file) 'wl-draft-insert-x-face-field-here) ;; allow nil mail-default-headers ;; check \n at th end of line for `mail-default-headers' 'wl-draft-check-new-line -; wl-draft-default-headers -; 'wl-draft-check-new-line )) (defun wl-draft-insert-mail-header-separator (&optional delimline) @@ -1634,7 +1885,8 @@ Derived from `message-save-drafts' in T-gnus." (progn (insert mail-header-separator "\n") (1- (point))) - 'category 'mail-header-separator))) + 'category 'mail-header-separator) + (point))) ;;;;;;;;;;;;;;;; @@ -1647,12 +1899,27 @@ Derived from `message-save-drafts' in T-gnus." (elmo-nntp-default-port (or wl-nntp-posting-port elmo-nntp-default-port)) (elmo-nntp-default-stream-type - (or wl-nntp-posting-stream-type elmo-nntp-default-stream-type))) + (or wl-nntp-posting-stream-type elmo-nntp-default-stream-type)) + (elmo-nntp-default-function wl-nntp-posting-function) + condition) + (if (setq condition (cdr (elmo-string-matched-assoc + (std11-field-body "Newsgroups") + wl-nntp-posting-config-alist))) + (if (stringp condition) + (setq elmo-nntp-default-server condition) + (while (car condition) + (set (intern (format "elmo-nntp-default-%s" + (symbol-name (caar condition)))) + (cdar condition)) + (setq condition (cdr condition))))) + (unless elmo-nntp-default-function + (error "wl-draft-nntp-send: posting-function is nil")) (if (not (elmo-plugged-p elmo-nntp-default-server elmo-nntp-default-port)) (wl-draft-set-sent-message 'news 'unplugged (cons elmo-nntp-default-server elmo-nntp-default-port)) - (elmo-nntp-post elmo-nntp-default-server (current-buffer)) + (funcall elmo-nntp-default-function + elmo-nntp-default-server (current-buffer)) (wl-draft-set-sent-message 'news 'sent) (wl-draft-write-sendlog 'ok 'nntp elmo-nntp-default-server (std11-field-body "Newsgroups") @@ -1661,118 +1928,127 @@ Derived from `message-save-drafts' in T-gnus." (defun wl-draft-generate-clone-buffer (name &optional local-variables) "Generate clone of current buffer named NAME." (let ((editing-buffer (current-buffer))) - (save-excursion - (set-buffer (generate-new-buffer name)) + (with-current-buffer (generate-new-buffer name) (erase-buffer) (wl-draft-mode) (wl-draft-editor-mode) - (insert-buffer editing-buffer) + (insert-buffer-substring editing-buffer) (message "") (while local-variables (make-local-variable (car local-variables)) (set (car local-variables) - (save-excursion - (set-buffer editing-buffer) + (with-current-buffer editing-buffer (symbol-value (car local-variables)))) (setq local-variables (cdr local-variables))) (current-buffer)))) +(defun wl-draft-remove-text-plain-tag () + "Remove text/plain tag of mime-edit." + (when (string= (mime-make-text-tag "plain") + (buffer-substring-no-properties (point-at-bol)(point-at-eol))) + (delete-region (point-at-bol)(1+ (point-at-eol))))) + (defun wl-draft-reedit (number) - (let ((draft-folder (wl-folder-get-elmo-folder wl-draft-folder)) + (let ((draft-folder (wl-draft-get-folder)) (wl-draft-reedit t) - buffer file-name change-major-mode-hook) - (setq file-name (elmo-message-file-name draft-folder number)) - (unless (file-exists-p file-name) - (error "File %s does not exist" file-name)) - (if (setq buffer (get-buffer - (concat wl-draft-folder "/" - (number-to-string number)))) - (progn - (if wl-draft-use-frame - (switch-to-buffer-other-frame buffer) - (switch-to-buffer buffer)) - (set-buffer buffer)) - (setq buffer (get-buffer-create (number-to-string number))) - (if wl-draft-use-frame - (switch-to-buffer-other-frame buffer) - (switch-to-buffer buffer)) - (set-buffer buffer) - (insert-file-contents-as-binary file-name) - (let((mime-edit-again-ignored-field-regexp - "^\\(Content-.*\\|Mime-Version\\):")) - (wl-draft-decode-message-in-buffer)) - (wl-draft-insert-mail-header-separator) - (if wl-draft-use-frame - (switch-to-buffer-other-frame buffer) - (switch-to-buffer buffer)) - (set-buffer buffer) - (if (not (string-match (regexp-quote wl-draft-folder) - (buffer-name))) - (rename-buffer (concat wl-draft-folder "/" (buffer-name)))) - (auto-save-mode -1) - (wl-draft-mode) - ;; Don't care about supersession. - (make-local-variable 'truncate-partial-width-windows) - (setq truncate-partial-width-windows nil) - (setq truncate-lines wl-draft-truncate-lines) - (setq buffer-file-name nil) - (setq wl-sent-message-via nil) - (setq wl-sent-message-queued nil) - (setq wl-draft-buffer-file-name file-name) - (wl-draft-config-info-operation number 'load) - (goto-char (point-min)) - (wl-draft-overload-functions) - (wl-draft-editor-mode) - (wl-highlight-headers 'for-draft) - (run-hooks 'wl-draft-reedit-hook) - (goto-char (point-max)) - buffer))) + (num 0) + buffer change-major-mode-hook body-top) + (setq buffer (get-buffer-create (format "%s/%d" wl-draft-folder + number))) + (if wl-draft-use-frame + (switch-to-buffer-other-frame buffer) + (switch-to-buffer buffer)) + (set-buffer 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\\):")) + (wl-draft-decode-message-in-buffer)) + (setq body-top (wl-draft-insert-mail-header-separator)) + (auto-save-mode -1) + (wl-draft-mode) + (make-local-variable 'truncate-partial-width-windows) + (setq truncate-partial-width-windows nil) + (setq truncate-lines wl-draft-truncate-lines) + (setq wl-sent-message-via nil) + (setq wl-sent-message-queued nil) + (wl-draft-config-info-operation number 'load) + (goto-char (point-min)) + (wl-draft-overload-functions) + (wl-draft-editor-mode) + (static-when (boundp 'auto-save-file-name-transforms) + (make-local-variable 'auto-save-file-name-transforms) + (setq auto-save-file-name-transforms + (cons (list (concat (regexp-quote wl-draft-folder) + "/\\([0-9]+\\)") + (concat (expand-file-name + "auto-save-" + (elmo-folder-msgdb-path + (wl-draft-get-folder))) + "\\1")) + auto-save-file-name-transforms))) + (setq buffer-file-name (buffer-name) + wl-draft-buffer-message-number number) + (unless wl-draft-parent-folder + (setq wl-draft-parent-folder "")) + (when wl-draft-write-file-function + (add-hook 'local-write-file-hooks wl-draft-write-file-function)) + (wl-highlight-headers 'for-draft) + (goto-char body-top) + (run-hooks 'wl-draft-reedit-hook) + (goto-char (point-max)) + buffer)) + +(defun wl-draft-body-goto-top () + (goto-char (point-min)) + (if (re-search-forward mail-header-separator nil t) + (forward-char 1) + (goto-char (point-max)))) -(defmacro wl-draft-body-goto-top () - (` (progn - (goto-char (point-min)) - (if (re-search-forward mail-header-separator nil t) - (forward-char 1) - (goto-char (point-max)))))) +(defun wl-draft-body-goto-bottom () + (goto-char (point-max))) -(defmacro wl-draft-body-goto-bottom () - (` (goto-char (point-max)))) +(defun wl-draft-config-body-goto-header () + (goto-char (point-min)) + (if (re-search-forward mail-header-separator nil t) + (beginning-of-line) + (goto-char (point-max)))) -(defmacro wl-draft-config-body-goto-header () - (` (progn - (goto-char (point-min)) - (if (re-search-forward mail-header-separator nil t) - (beginning-of-line) - (goto-char (point-max)))))) +(defsubst wl-draft-config-sub-eval-insert (content &optional newline) + (let (content-value) + (when (and content + (stringp (setq content-value (eval content)))) + (insert content-value) + (if newline (insert "\n"))))) (defun wl-draft-config-sub-body (content) (wl-draft-body-goto-top) (delete-region (point) (point-max)) - (if content (insert (eval content)))) + (wl-draft-config-sub-eval-insert content)) (defun wl-draft-config-sub-top (content) (wl-draft-body-goto-top) - (if content (insert (eval content)))) + (wl-draft-config-sub-eval-insert content)) (defun wl-draft-config-sub-bottom (content) (wl-draft-body-goto-bottom) - (if content (insert (eval content)))) + (wl-draft-config-sub-eval-insert content)) (defun wl-draft-config-sub-header (content) (wl-draft-config-body-goto-header) - (if content (insert (concat (eval content) "\n")))) + (wl-draft-config-sub-eval-insert content 'newline)) (defun wl-draft-config-sub-header-top (content) (goto-char (point-min)) - (if content (insert (concat (eval content) "\n")))) + (wl-draft-config-sub-eval-insert content 'newline)) (defun wl-draft-config-sub-part-top (content) (goto-char (mime-edit-content-beginning)) - (if content (insert (concat (eval content) "\n")))) + (wl-draft-config-sub-eval-insert content 'newline)) (defun wl-draft-config-sub-part-bottom (content) (goto-char (mime-edit-content-end)) - (if content (insert (concat (eval content) "\n")))) + (wl-draft-config-sub-eval-insert content 'newline)) (defsubst wl-draft-config-sub-file (content) (let ((coding-system-for-read wl-cs-autoconv) @@ -1857,7 +2133,8 @@ Derived from `message-save-drafts' in T-gnus." (wl-draft-config-exec config-alist reply-buf))))) (defun wl-draft-config-exec (&optional config-alist reply-buf) - "Change headers in draft sending time." + "Change headers according to the value of `wl-draft-config-alist'. +Automatically applied in draft sending time." (interactive) (let ((case-fold-search t) (alist (or config-alist wl-draft-config-alist)) @@ -1877,8 +2154,7 @@ Derived from `message-save-drafts' in T-gnus." ((eq key 'reply) (when (and reply-buf - (save-excursion - (set-buffer reply-buf) + (with-current-buffer reply-buf (save-restriction (std11-narrow-to-header) (goto-char (point-min)) @@ -1899,14 +2175,14 @@ Derived from `message-save-drafts' in T-gnus." (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 @@ -1938,13 +2214,14 @@ Derived from `message-save-drafts' in T-gnus." (goto-char (point-max)) (insert (concat field ": " content "\n")))))))) +(defsubst wl-draft-config-info-filename (number msgdb-dir) + (expand-file-name + (format "%s-%d" wl-draft-config-save-filename number) + msgdb-dir)) + (defun wl-draft-config-info-operation (msg operation) - (let* ((msgdb-dir (elmo-folder-msgdb-path (wl-folder-get-elmo-folder - wl-draft-folder))) - (filename - (expand-file-name - (format "%s-%d" wl-draft-config-save-filename msg) - msgdb-dir)) + (let* ((msgdb-dir (elmo-folder-msgdb-path (wl-draft-get-folder))) + (filename (wl-draft-config-info-filename msg msgdb-dir)) element alist variable) (cond ((eq operation 'save) @@ -2004,7 +2281,7 @@ Derived from `message-save-drafts' in T-gnus." (let ((send-buffer (current-buffer)) (folder (wl-folder-get-elmo-folder wl-queue-folder)) (message-id (std11-field-body "Message-ID"))) - (if (elmo-folder-append-buffer folder t) + (if (elmo-folder-append-buffer folder) (progn (wl-draft-queue-info-operation (car (elmo-folder-status folder)) @@ -2060,8 +2337,7 @@ Derived from `message-save-drafts' in T-gnus." (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 @@ -2095,40 +2371,31 @@ Derived from `message-save-drafts' in T-gnus." (interactive "P") (if arg (wl-jump-to-draft-folder) - (let ((bufs (buffer-list)) - (draft-regexp (concat - "^" (regexp-quote - (elmo-localdir-folder-directory-internal - (wl-folder-get-elmo-folder wl-draft-folder))))) - buf draft-bufs) - (while bufs - (if (and - (setq buf (with-current-buffer (car bufs) - wl-draft-buffer-file-name)) - (string-match draft-regexp buf)) - (setq draft-bufs (cons (buffer-name (car bufs)) draft-bufs))) - (setq bufs (cdr bufs))) + (let ((draft-bufs (wl-collect-draft)) + buf) (cond ((null draft-bufs) (message "No draft buffer exist.")) (t (setq draft-bufs - (sort draft-bufs (function (lambda (a b) (not (string< a b)))))) - (if (setq buf (cdr (member (buffer-name) draft-bufs))) + (sort (mapcar 'buffer-name draft-bufs) + (function (lambda (a b) + (not (string< a b)))))) + (if (setq buf (cdr (member (buffer-name) + draft-bufs))) (setq buf (car buf)) (setq buf (car draft-bufs))) (switch-to-buffer buf)))))) (defun wl-jump-to-draft-folder () - (let ((msgs (reverse (elmo-folder-list-messages (wl-folder-get-elmo-folder - wl-draft-folder)))) + (let ((msgs (reverse (elmo-folder-list-messages (wl-draft-get-folder)))) (mybuf (buffer-name)) msg buf) (if (not msgs) (message "No draft message exist.") (if (string-match (concat "^" wl-draft-folder "/") mybuf) (setq msg (cadr (memq - (string-to-int (substring mybuf (match-end 0))) + (string-to-number (substring mybuf (match-end 0))) msgs)))) (or msg (setq msg (car msgs))) (if (setq buf (get-buffer (format "%s/%d" wl-draft-folder msg))) @@ -2137,13 +2404,93 @@ Derived from `message-save-drafts' in T-gnus." (defun wl-draft-highlight-and-recenter (&optional n) (interactive "P") - (if wl-highlight-body-too - (let ((beg (point-min)) - (end (point-max))) - (put-text-property beg end 'face nil) - (wl-highlight-message beg end t))) + (when wl-highlight-body-too + (let ((modified (buffer-modified-p))) + (unwind-protect + (progn + (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 +(defvar wl-draft-current-history-position nil) +(defvar wl-draft-history-backup-word "") + +(defun wl-draft-previous-history-element (n) + (interactive "p") + (let (bol history beg end prev new) + (when (and (not (wl-draft-on-field-p)) + (< (point) + (save-excursion + (goto-char (point-min)) + (search-forward (concat "\n" mail-header-separator "\n") nil 0) + (point))) + (save-excursion + (beginning-of-line) + (while (and (looking-at "^[ \t]") + (not (= (point) (point-min)))) + (forward-line -1)) + (cond + ((looking-at wl-folder-complete-header-regexp) + (and (boundp 'wl-read-folder-history) + (setq history wl-read-folder-history))) +;;; ((looking-at wl-address-complete-header-regexp) +;;; (setq history .....)) + (t + nil))) + (eolp)) + (setq bol (save-excursion (beginning-of-line) (point))) + (cond ((and (or (eq last-command 'wl-draft-previous-history-element) + (eq last-command 'wl-draft-next-history-element)) + wl-draft-current-history-position) + (setq end (point)) + (or (search-backward-regexp ",[ \t]*\\(.*\\)" bol t) + (search-backward-regexp "^[ \t]\\(.*\\)" bol t) + (search-backward-regexp "^[^ \t]*: \\(.*\\)" bol t)) + (setq prev (match-string 1)) + (goto-char (match-beginning 1)) + (setq beg (point)) + (if (cond ((< n 0) + (>= (+ n wl-draft-current-history-position) 0)) + ((> n 0) + (<= (+ n wl-draft-current-history-position) + (length history)))) + (progn + (setq wl-draft-current-history-position + (+ n wl-draft-current-history-position)) + (setq new + (nth wl-draft-current-history-position + (append (list wl-draft-history-backup-word) + history))) + (delete-region beg end) + (insert new)) + (goto-char end) + (cond ((< n 0) + (message "End of history; no next item")) + ((> n 0) + (message "Beginning of history; no preceding item"))))) + ((and (> n 0) + (save-excursion + (or (search-backward-regexp ",[ \t]*\\(.*\\)" bol t) + (search-backward-regexp "^[ \t]\\(.*\\)" bol t) + (search-backward-regexp "^[^ \t]*: \\(.*\\)" bol t))) + (car history)) + (setq wl-draft-current-history-position 1) + (setq wl-draft-history-backup-word (match-string 1)) + (delete-region (match-beginning 1) (match-end 1)) + (insert (car history))) + (t + (setq wl-draft-current-history-position nil)))))) + +(defun wl-draft-next-history-element (n) + (interactive "p") + (wl-draft-previous-history-element (- n))) + ;;;; user-agent support by Sen Nagata ;; this appears to be necessarily global... @@ -2180,7 +2527,8 @@ Derived from `message-save-drafts' in T-gnus." (goto-char (point-min)) (search-forward mail-header-separator) (forward-line 1) - (insert body-text)) + (insert body-text) + (or (bolp) (insert "\n"))) ;;;###autoload (defun wl-user-agent-compose (&optional to subject other-headers continue @@ -2193,35 +2541,29 @@ been implemented yet. Partial support for SWITCH-FUNCTION now supported." (unless (featurep 'wl) (require 'wl)) + (or switch-function + (setq switch-function 'keep)) ;; protect these -- to and subject get bound at some point, so it looks ;; to be necessary to protect the values used w/in (let ((wl-user-agent-headers-and-body-alist other-headers) (wl-draft-use-frame (eq switch-function 'switch-to-buffer-other-frame)) - (wl-draft-reply-buffer-style 'split)) - (when (eq switch-function 'switch-to-buffer-other-window) - (when (one-window-p t) - (if (window-minibuffer-p) (other-window 1)) - (split-window)) - (other-window 1)) + (wl-draft-buffer-style switch-function) + tem) (if to - (if (wl-string-match-assoc "to" wl-user-agent-headers-and-body-alist - 'ignore-case) - (setcdr - (wl-string-match-assoc "to" wl-user-agent-headers-and-body-alist - 'ignore-case) - to) + (if (setq tem (wl-string-match-assoc + "\\`to\\'" + wl-user-agent-headers-and-body-alist + 'ignore-case)) + (setcdr tem to) (setq wl-user-agent-headers-and-body-alist (cons (cons "to" to) wl-user-agent-headers-and-body-alist)))) (if subject - (if (wl-string-match-assoc "subject" - wl-user-agent-headers-and-body-alist - 'ignore-case) - (setcdr - (wl-string-match-assoc "subject" - wl-user-agent-headers-and-body-alist - 'ignore-case) - subject) + (if (setq tem (wl-string-match-assoc + "\\`subject\\'" + wl-user-agent-headers-and-body-alist + 'ignore-case)) + (setcdr tem subject) (setq wl-user-agent-headers-and-body-alist (cons (cons "subject" subject) wl-user-agent-headers-and-body-alist)))) @@ -2253,14 +2595,34 @@ been implemented yet. Partial support for SWITCH-FUNCTION now supported." ;; highlight headers (from wl-draft in wl-draft.el) (wl-highlight-headers 'for-draft) ;; insert body - (if (wl-string-match-assoc "body" wl-user-agent-headers-and-body-alist - 'ignore-case) - (wl-user-agent-insert-body - (cdr (wl-string-match-assoc - "body" - wl-user-agent-headers-and-body-alist 'ignore-case))))) + (let ((body (wl-string-match-assoc "\\`body\\'" + wl-user-agent-headers-and-body-alist + 'ignore-case))) + (if body + (wl-user-agent-insert-body (cdr body))))) 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))) + +(defun wl-draft-buffer-change-number (old-number new-number) + (when (eq wl-draft-buffer-message-number old-number) + (setq wl-draft-buffer-message-number new-number) + (rename-buffer (format "%s/%d" wl-draft-folder new-number) t) + (setq buffer-file-name (buffer-name)) + (set-buffer-modified-p nil))) + +(defun wl-draft-rename-saved-config (old-number new-number) + (let* ((msgdb-dir (elmo-folder-msgdb-path (wl-draft-get-folder))) + (old-name (wl-draft-config-info-filename old-number msgdb-dir)) + (new-name (wl-draft-config-info-filename new-number msgdb-dir))) + (when (file-exists-p old-name) + (rename-file old-name new-name 'ok-if-already-exists)))) + (require 'product) (product-provide (provide 'wl-draft) (require 'wl-version))