X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=wl%2Fwl-draft.el;h=28b73b2dbd6a2391a916a783a0f709d5bb846802;hb=33d9128fae4ddb2529278fbf8a0bebc0ee64d2c4;hp=9ccf8dd94c66648dd83b841b99895d9a9a6fc439;hpb=a286a712beb03a4a8c05a932dbbb73c17d6ba5c4;p=elisp%2Fwanderlust.git diff --git a/wl/wl-draft.el b/wl/wl-draft.el index 9ccf8dd..28b73b2 100644 --- a/wl/wl-draft.el +++ b/wl/wl-draft.el @@ -135,32 +135,32 @@ e.g. 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-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)))) + `(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." @@ -326,8 +326,9 @@ e.g. result)) (defun wl-draft-reply (buf with-arg summary-buf &optional number) - "Reply to BUF buffer message. -Reply to author if WITH-ARG is non-nil." + "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 ((rule-list (if with-arg 'wl-draft-reply-with-argument-list @@ -406,7 +407,7 @@ Reply to author if WITH-ARG is non-nil." (setq mail-followup-to (wl-delete-duplicates mail-followup-to nil t))) (with-temp-buffer ; to keep raw buffer unibyte. (set-buffer-multibyte default-enable-multibyte-characters) - (setq newsgroups (wl-parse newsgroups + (setq newsgroups (elmo-parse newsgroups "[ \t\f\r\n,]*\\([^ \t\f\r\n,]+\\)") newsgroups (wl-delete-duplicates newsgroups) newsgroups @@ -422,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) @@ -486,8 +487,7 @@ Reply to author if WITH-ARG is non-nil." (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)) @@ -755,9 +755,8 @@ Reply to author if WITH-ARG is non-nil." (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) + (when editing-buffer + (with-current-buffer editing-buffer (when wl-draft-buffer-message-number (elmo-folder-delete-messages (wl-draft-get-folder) (list @@ -827,16 +826,16 @@ text was killed." ;; 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) @@ -866,7 +865,7 @@ 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) "")) @@ -1069,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) @@ -1169,7 +1167,7 @@ If FORCE-MSGID, insert message-id regardless of `wl-insert-message-id'." nil t) (when (string= "" (match-string 1)) (replace-match "")))) -;;; (run-hooks 'wl-mail-send-pre-hook) ;; X-PGP-Sig, Cancel-Lock +;;; (run-hooks 'wl-mail-send-pre-hook) ; X-PGP-Sig, Cancel-Lock (wl-draft-dispatch-message) (when kill-when-done ;; hide editing-buffer. @@ -1281,7 +1279,8 @@ This variable is valid when `wl-interactive-send' has non-nil value." (condition-case nil (progn (when wl-draft-send-confirm-with-preview - (let (wl-draft-send-hook) + (let (wl-draft-send-hook + (pgg-decrypt-automatically nil)) (wl-draft-preview-message))) (save-excursion (goto-char (point-min)) ; to show recipients in header @@ -1302,9 +1301,9 @@ This variable is valid when `wl-interactive-send' has non-nil value." "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) (wl-draft-send-confirm)) @@ -1320,8 +1319,7 @@ If KILL-WHEN-DONE is non-nil, current draft buffer is killed" (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")) @@ -1344,8 +1342,11 @@ If KILL-WHEN-DONE is non-nil, current draft buffer is killed" ;; 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)) + (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 @@ -1398,7 +1399,7 @@ If KILL-WHEN-DONE is non-nil, current draft buffer is killed" "This is a blind carbon copy.") "\n") (mime-edit-insert-tag "message" "rfc822") - (insert-buffer draft-buffer) + (insert-buffer-substring draft-buffer) (let (wl-interactive-send) (wl-draft-send 'kill-when-done)))))))) @@ -1554,15 +1555,12 @@ If KILL-WHEN-DONE is non-nil, current draft buffer is killed" (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) @@ -1583,8 +1581,7 @@ If KILL-WHEN-DONE is non-nil, current draft buffer is killed" (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))))) - (kill-buffer tembuf))) + (setq fcc-list (cdr fcc-list))))))) (defun wl-draft-on-field-p () (if (< (point) @@ -1671,8 +1668,6 @@ If KILL-WHEN-DONE is non-nil, current draft buffer is killed" (defun wl-draft-create-buffer (&optional parent-folder parent-number) (let* ((draft-folder (wl-draft-get-folder)) - (parent-folder (or parent-folder (wl-summary-buffer-folder-name))) - (summary-buf (wl-summary-get-buffer parent-folder)) (reply-or-forward (or (eq this-command 'wl-summary-reply) (eq this-command 'wl-summary-reply-with-citation) @@ -1727,7 +1722,8 @@ If KILL-WHEN-DONE is non-nil, current draft buffer is killed" (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 summary-buf)) + (setq wl-draft-buffer-cur-summary-buffer + (wl-summary-get-buffer parent-folder))) buffer)) (defun wl-draft-create-contents (header-alist) @@ -1853,7 +1849,7 @@ If KILL-WHEN-DONE is non-nil, current draft buffer is killed" 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 @@ -1882,7 +1878,7 @@ If KILL-WHEN-DONE is non-nil, current draft buffer is killed" (goto-char delimline) (goto-char (point-min)) (if (search-forward "\n\n" nil t) - (delete-backward-char 1) + (delete-char -1) (goto-char (point-max)))) (wl-draft-check-new-line) (put-text-property (point) @@ -1932,18 +1928,16 @@ If KILL-WHEN-DONE is non-nil, current draft buffer is killed" (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)))) @@ -1994,8 +1988,9 @@ If KILL-WHEN-DONE is non-nil, current draft buffer is killed" "\\1")) auto-save-file-name-transforms))) (setq buffer-file-name (buffer-name) - wl-draft-parent-folder "" 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) @@ -2004,22 +1999,20 @@ If KILL-WHEN-DONE is non-nil, current draft buffer is killed" (goto-char (point-max)) buffer)) -(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-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-bottom () - (` (goto-char (point-max)))) +(defun wl-draft-body-goto-bottom () + (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)))))) +(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)))) (defsubst wl-draft-config-sub-eval-insert (content &optional newline) (let (content-value) @@ -2161,8 +2154,7 @@ Automatically applied in draft sending time." ((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)) @@ -2403,7 +2395,7 @@ Automatically applied in draft sending time." (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))) @@ -2447,8 +2439,8 @@ Automatically applied in draft sending time." ((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 .....)) +;;; ((looking-at wl-address-complete-header-regexp) +;;; (setq history .....)) (t nil))) (eolp)) @@ -2535,7 +2527,8 @@ Automatically applied in draft sending time." (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 @@ -2554,26 +2547,23 @@ been implemented yet. Partial support for SWITCH-FUNCTION now supported." ;; 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-buffer-style switch-function)) + (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)))) @@ -2605,12 +2595,11 @@ 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)