;;; Code:
;;
-
+(require 'elmo)
(require 'sendmail)
(require 'wl-template)
(require 'emu)
(\"From\" . \"user@domain2\"))))")
(defvar wl-draft-parent-number nil)
+(defvar wl-draft-parent-flag nil)
-(defconst wl-draft-reply-saved-variables
+(defconst wl-draft-parent-variables
'(wl-draft-parent-folder
- wl-draft-parent-number))
+ wl-draft-parent-number
+ wl-draft-parent-flag))
(defvar wl-draft-config-sub-func-alist
'((body . wl-draft-config-sub-body)
(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.")
(if (eq wl-smtp-connection-type 'ssl)
#'open-ssl-stream
smtp-open-connection-function))
- (smtp-end-of-line
- (if (eq wl-smtp-connection-type 'ssl)
- "\n"
- smtp-end-of-line))
smtp-sasl-user-name smtp-sasl-properties sasl-read-passphrase)
- (if (and (string= (car smtp-sasl-mechanisms) "DIGEST-MD5")
- ;; sendmail bug?
- (string-match "^\\([^@]*\\)@\\([^@]*\\)"
- wl-smtp-posting-user))
- (setq smtp-sasl-user-name (match-string 1 wl-smtp-posting-user)
- smtp-sasl-properties (list 'realm
- (match-string 2 wl-smtp-posting-user)))
- (setq smtp-sasl-user-name wl-smtp-posting-user
- smtp-sasl-properties nil))
+ (setq smtp-sasl-user-name wl-smtp-posting-user
+ smtp-sasl-properties (when wl-smtp-authenticate-realm
+ (list 'realm
+ wl-smtp-authenticate-realm)))
(setq sasl-read-passphrase
(function
(lambda (prompt)
(let (references parent-folder subject)
(with-current-buffer summary-buf
(setq parent-folder (wl-summary-buffer-folder-name)))
- (setq subject (wl-draft-forward-make-subject original-subject))
+ (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"))))
(wl-draft (list (cons 'To "")
(cons 'Subject subject)
(cons 'References references))
- nil nil nil nil parent-folder))
- (setq wl-draft-parent-number number)
+ nil nil nil nil parent-folder number))
(goto-char (point-max))
(wl-draft-insert-message)
(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 (buf with-arg summary-buf &optional number)
"Reply to BUF buffer message.
Reply to author if WITH-ARG 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
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 r-list (if with-arg wl-draft-reply-with-argument-list
- wl-draft-reply-without-argument-list))
- (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
- (cond
- ((stringp (car condition))
- (or (std11-field-body (car condition))
- (throw 'done nil)))
- ((symbolp (car condition))
- (or (funcall (car condition))
- (throw 'done nil)))
- (t
- (debug)))
- (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))))
- (if (and r-to-list (symbolp r-to-list))
- (setq to (wl-concat-list (funcall r-to-list) ","))
- (setq to (wl-concat-list (cons to
- (elmo-multiple-fields-body-list
- r-to-list))
- ",")))
- (if (and r-cc-list (symbolp r-cc-list))
- (setq cc (wl-concat-list (funcall r-cc-list) ","))
- (setq cc (wl-concat-list (cons cc
- (elmo-multiple-fields-body-list
- r-cc-list))
- ",")))
- (if (and r-ng-list (symbolp r-ng-list))
- (setq newsgroups (wl-concat-list (funcall r-ng-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 `wl-draft-reply-%s-argument-list'"
- (if with-arg "with" "without")))
+ (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.
(set-buffer-multibyte default-enable-multibyte-characters)
(setq decoder (mime-find-field-decoder 'Subject 'plain))
- (setq subject (wl-draft-reply-make-subject
- (if (and subject decoder)
- (funcall decoder subject) subject)))
+ (setq subject (if (and subject decoder)
+ (funcall decoder subject) subject))
(setq to-alist
(mapcar
(lambda (addr)
(cons (nth 1 (std11-extract-address-components addr))
(if decoder (funcall decoder addr) addr)))
cc)))
+ (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"))
(cons 'In-Reply-To in-reply-to)
(cons 'References references)
(cons 'Mail-Followup-To mail-followup-to))
- nil nil nil nil parent-folder)
- (setq wl-draft-parent-number number)
+ nil nil nil nil parent-folder number)
(setq wl-draft-reply-buffer buf)
(setq wl-draft-config-variables
- (append wl-draft-reply-saved-variables
- 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)
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))))
"Yank original message."
(interactive "P")
(if arg
- (let (buf mail-reply-buffer)
- (elmo-set-work-buf
- (insert "\n")
- (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)
(set-buffer-modified-p nil) ; force kill
(kill-buffer editing-buffer))))
-(defun wl-draft-kill-flags ()
- "Remove flags on parent message when current draft is killed."
- (let ((buffer (wl-summary-get-buffer wl-draft-parent-folder))
- (number wl-draft-parent-number)
- folder)
- (if buffer
- (with-current-buffer buffer
- (dolist (flag wl-draft-kill-flags)
- (wl-summary-unset-persistent-mark flag number)))
- ;; Parent buffer does not exist.
- (when (setq folder (and wl-draft-parent-folder
- (string< "" wl-draft-parent-folder)
- (wl-folder-get-elmo-folder
- wl-draft-parent-folder)))
- (elmo-folder-open folder 'load-msgdb)
- (dolist (flag wl-draft-kill-flags)
- (elmo-folder-unset-flag folder (list wl-draft-parent-number) flag))
- (elmo-folder-close folder)))))
-
(defun wl-draft-kill (&optional force-kill)
"Kill current draft buffer and quit editing."
(interactive "P")
(re-search-forward "\n[ \t]*\n\n*" nil t))
(replace-match "\n"))
(goto-char (point-min))
- (while (re-search-forward
+ (while (re-search-forward
"^[^ \t\n:]+:[ \t]*\\(.*\\(\n[ \t].*\\)*\\)\n"
nil t)
(when (string= "" (match-string 1))
result))
(defcustom wl-draft-send-confirm-with-preview t
- "Non-nil to invoke preview through confirmation of sending.
+ "*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 ()
- (let (answer)
- (unwind-protect
- (condition-case quit
- (progn
- (when wl-draft-send-confirm-with-preview
- (wl-draft-preview-message))
- (save-excursion
- (goto-char (point-min)) ; to show recipients in header
- (catch 'done
- (while t
- (discard-input)
- (message "Send current draft? <y/n/j(down)/k(up)> ")
- (setq answer (let ((cursor-in-echo-area t)) (read-char)))
- (cond
- ((or (eq answer ?y)
- (eq answer ?Y)
- (eq answer ? ))
- (throw 'done t))
- ((or (eq answer ?v)
- (eq answer ?j)
- (eq answer ?J))
- (condition-case err
- (scroll-up)
- (error nil)))
- ((or (eq answer ?^)
- (eq answer ?k)
- (eq answer ?K))
- (condition-case err
- (scroll-down)
- (error nil)))
- (t
- (throw 'done nil)))))))
- (quit nil))
- (when wl-draft-send-confirm-with-preview
- (mime-preview-quit)))))
+ (unwind-protect
+ (condition-case nil
+ (progn
+ (when wl-draft-send-confirm-with-preview
+ (let (wl-draft-send-hook)
+ (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.
" *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
;;
(if wl-draft-verbose-send
(message "%s" (or mes-string "Sending...")))
+ ;; Set flag before send-function because
+ ;; there's no need to change current mailbox at this time.
+ ;; If flag is set after send-function, the current mailbox
+ ;; might changed by Fcc.
+ ;; It causes a huge loss in the IMAP folder.
+ (when (and parent-flag parent-number
+ (not (eq (length parent-folder) 0)))
+ (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
(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))
+ (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)
(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)))
(defun wl-draft (&optional header-alist
content-type content-transfer-encoding
body edit-again
- parent-folder)
+ parent-folder
+ parent-number)
"Write and send mail/news message with Wanderlust."
(interactive)
(require 'wl)
(let (wl-demo)
(wl-init)) ; returns immediately if already initialized.
-
+ (wl-start-save-drafts)
(let (buffer header-alist-internal)
- (setq buffer (wl-draft-create-buffer parent-folder))
+ (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)))
(goto-char (point-max))))
buffer))
-(defun wl-draft-create-buffer (&optional parent-folder)
+(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)
(eq this-command 'wl-summary-forward)
(eq this-command 'wl-summary-target-mark-forward)
(eq this-command 'wl-summary-target-mark-reply-with-citation)))
- (buffer (generate-new-buffer "*draft*")) ; Just for initial name.
- change-major-mode-hook)
+ (buffer (generate-new-buffer "*draft*"))) ; Just for initial name.
(set-buffer buffer)
;; switch-buffer according to draft buffer style.
(if wl-draft-use-frame
(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 wl-sent-message-queued nil)
(setq wl-draft-config-exec-flag t)
(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)
(switch-to-buffer-other-frame buffer)
(switch-to-buffer buffer))
(set-buffer buffer)
- (elmo-message-fetch draft-folder number (elmo-make-fetch-strategy 'entire)
- nil (current-buffer))
+ (elmo-message-fetch draft-folder number (elmo-make-fetch-strategy 'entire))
(elmo-delete-cr-buffer)
(let ((mime-edit-again-ignored-field-regexp
"^\\(Content-.*\\|Mime-Version\\):"))
"\\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)
(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-draft-get-folder)))
- (filename
- (expand-file-name
- (format "%s-%d" wl-draft-config-save-filename msg)
- msgdb-dir))
+ (filename (wl-draft-config-info-filename msg msgdb-dir))
element alist variable)
(cond
((eq operation 'save)
(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
wl-user-agent-headers-and-body-alist 'ignore-case)))))
t))
+(defun wl-draft-setup-parent-flag (flag)
+ "Setup a FLAG for parent message."
+ (when (and (> (length wl-draft-parent-folder) 0)
+ wl-draft-parent-number)
+ (setq wl-draft-parent-flag flag)
+ (wl-draft-config-info-operation wl-draft-buffer-message-number 'save)))
+
+(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))
projects / elisp / wanderlust.git / blobdiff