X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;ds=sidebyside;f=wl%2Fwl-draft.el;h=c30d60ff59f9b211946497afda5493e7150bf20a;hb=7c4c242d5cf095fb9894d23b726b41a0afa4ee1b;hp=017e61e58ab3288502036b47a04e515c31f1323d;hpb=0fd1dbee05cddb8e63c5925608a42002a8f7549c;p=elisp%2Fwanderlust.git diff --git a/wl/wl-draft.el b/wl/wl-draft.el index 017e61e..c30d60f 100644 --- a/wl/wl-draft.el +++ b/wl/wl-draft.el @@ -1,4 +1,4 @@ -;;; wl-draft.el -- Message draft mode for Wanderlust. +;;; wl-draft.el --- Message draft mode for Wanderlust. ;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi ;; Copyright (C) 1998,1999,2000 Masahiro MURATA @@ -26,10 +26,10 @@ ;; ;;; Commentary: -;; +;; ;;; Code: -;; +;; (require 'sendmail) (require 'wl-template) @@ -73,18 +73,23 @@ (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-config-sub-func-alist - '((body . wl-draft-config-sub-body) - (top . wl-draft-config-sub-top) - (bottom . wl-draft-config-sub-bottom) - (header . wl-draft-config-sub-header) - (body-file . wl-draft-config-sub-body-file) - (top-file . wl-draft-config-sub-top-file) - (bottom-file . wl-draft-config-sub-bottom-file) - (header-file . wl-draft-config-sub-header-file) - (template . wl-draft-config-sub-template) - (x-face . wl-draft-config-sub-x-face))) + '((body . wl-draft-config-sub-body) + (top . wl-draft-config-sub-top) + (bottom . wl-draft-config-sub-bottom) + (header . wl-draft-config-sub-header) + (header-top . wl-draft-config-sub-header-top) + (header-bottom . wl-draft-config-sub-header) + (part-top . wl-draft-config-sub-part-top) + (part-bottom . wl-draft-config-sub-part-bottom) + (body-file . wl-draft-config-sub-body-file) + (top-file . wl-draft-config-sub-top-file) + (bottom-file . wl-draft-config-sub-bottom-file) + (header-file . wl-draft-config-sub-header-file) + (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-cur-summary-buffer) @@ -93,6 +98,7 @@ (make-variable-buffer-local 'wl-sent-message-via) (make-variable-buffer-local 'wl-draft-fcc-list) (make-variable-buffer-local 'wl-draft-reply-buffer) +(make-variable-buffer-local 'wl-draft-parent-folder) (defmacro wl-smtp-extension-bind (&rest body) (` (let* ((smtp-sasl-mechanisms @@ -109,7 +115,7 @@ (string-match "^\\([^@]*\\)@\\([^@]*\\)" wl-smtp-posting-user)) (setq smtp-sasl-user-name (match-string 1 wl-smtp-posting-user) - smtp-sasl-properties (list 'realm + 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)) @@ -253,7 +259,7 @@ (mail-position-on-field "To")) (defun wl-draft-strip-subject-re (subject) - "Remove \"Re:\" from subject lines. Shamelessly copied from Gnus" + "Remove \"Re:\" from subject lines. Shamelessly copied from Gnus." (if (string-match wl-subject-prefix-regexp subject) (substring subject (match-end 0)) subject)) @@ -275,7 +281,9 @@ Reply to author if WITH-ARG is non-nil." ;;;(save-excursion (let (r-list to mail-followup-to cc subject in-reply-to references newsgroups - from to-alist cc-alist decoder) + 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 @@ -323,14 +331,14 @@ Reply to author if WITH-ARG is non-nil." (setq decoder (mime-find-field-decoder 'Subject 'plain)) (setq subject (if (and subject decoder) (funcall decoder subject) subject)) - (setq to-alist + (setq to-alist (mapcar (lambda (addr) (setq decoder (mime-find-field-decoder 'To 'plain)) (cons (nth 1 (std11-extract-address-components addr)) (if decoder (funcall decoder addr) addr))) to)) - (setq cc-alist + (setq cc-alist (mapcar (lambda (addr) (setq decoder (mime-find-field-decoder 'Cc 'plain)) @@ -339,7 +347,7 @@ Reply to author if WITH-ARG is non-nil." cc))) (and wl-reply-subject-prefix (setq subject (concat wl-reply-subject-prefix - (wl-draft-strip-subject-re + (wl-draft-strip-subject-re (or subject ""))))) (setq in-reply-to (std11-field-body "Message-Id")) (setq references (nconc @@ -355,10 +363,18 @@ Reply to author if WITH-ARG is non-nil." (setq mail-followup-to (wl-draft-make-mail-followup-to (append to cc))) (setq mail-followup-to (wl-delete-duplicates mail-followup-to nil t))) - (setq newsgroups (wl-parse newsgroups - "[ \t\f\r\n,]*\\([^ \t\f\r\n,]+\\)") - newsgroups (wl-delete-duplicates newsgroups) - newsgroups (if newsgroups (mapconcat 'identity newsgroups ","))) + (with-temp-buffer ; to keep raw buffer unibyte. + (elmo-set-buffer-multibyte default-enable-multibyte-characters) + (setq newsgroups (wl-parse newsgroups + "[ \t\f\r\n,]*\\([^ \t\f\r\n,]+\\)") + newsgroups (wl-delete-duplicates newsgroups) + newsgroups + (if newsgroups + (mapconcat + (lambda (grp) + (setq decoder (mime-find-field-decoder 'Newsgroups 'plain)) + (if decoder (funcall decoder grp) grp)) + newsgroups ",")))) (setq to (wl-delete-duplicates to nil t)) (setq cc (wl-delete-duplicates (append (wl-delete-duplicates cc nil t) @@ -393,32 +409,36 @@ Reply to author if WITH-ARG is non-nil." (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 nil nil nil summary-buf nil parent-folder) (setq wl-draft-reply-buffer buf)) (run-hooks 'wl-reply-hook)) (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) - (std11-field-body "message-id"))) - (ref (std11-field-body "References")) - (ref-list nil) (st nil)) + (set-buffer mail-reply-buffer) + (std11-field-body "message-id"))) + (field (or alt-field "In-Reply-To")) + (ref (std11-field-body field)) + (ref-list nil) (st nil)) (when (and mes-id ref) (while (string-match "<[^>]+>" ref st) - (setq ref-list - (cons (substring ref (match-beginning 0) (setq st (match-end 0))) - ref-list))) + (setq ref-list + (cons (substring ref (match-beginning 0) (setq st (match-end 0))) + ref-list))) (when (and ref-list (member mes-id ref-list)) (setq mes-id nil))) (when mes-id (save-excursion - (when (mail-position-on-field "References") - (forward-line) - (while (looking-at "^[ \t]") - (forward-line)) - (setq mes-id (concat "\t" mes-id "\n"))) - (insert mes-id)) + (when (mail-position-on-field field) + (forward-line) + (while (looking-at "^[ \t]") + (forward-line)) + (setq mes-id (concat "\t" mes-id "\n"))) + (insert mes-id)) t))) (defun wl-draft-yank-from-mail-reply-buffer (decode-it @@ -437,15 +457,17 @@ Reply to author if WITH-ARG is non-nil." (goto-char (point-min)) (wl-draft-delete-fields ignored-fields)) (goto-char (point-max)) - (push-mark) + (push-mark (point) nil t) (goto-char (point-min))) (let ((beg (point))) (cond (mail-citation-hook (run-hooks 'mail-citation-hook)) (mail-yank-hooks (run-hooks 'mail-yank-hooks)) (wl-draft-cite-function (funcall wl-draft-cite-function))) ; default cite (run-hooks 'wl-draft-cited-hook) - (when (and wl-draft-add-references - (wl-draft-add-references)) + (when (if wl-draft-add-references + (wl-draft-add-references) + (if wl-draft-add-in-reply-to + (wl-draft-add-in-reply-to))) (wl-highlight-headers 'for-draft)) ; highlight when added References: (when wl-highlight-body-too (wl-highlight-body-region beg (point-max))))) @@ -551,7 +573,8 @@ Reply to author if WITH-ARG is non-nil." (let (original-buffer mail-reply-buffer mail-citation-hook mail-yank-hooks - wl-draft-add-references wl-draft-cite-function) + 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)) @@ -695,7 +718,7 @@ 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?"))) + (y-or-n-p "Kill Current Draft? "))) (let ((cur-buf (current-buffer))) (wl-draft-hide cur-buf) (wl-draft-delete cur-buf))) @@ -736,9 +759,8 @@ Reply to author if WITH-ARG is non-nil." (defun wl-draft-write-sendlog (status proto server to id) "Write send log file, if `wl-draft-sendlog' is non-nil." (when wl-draft-sendlog - (save-excursion - (let* ((tmp-buf (get-buffer-create " *wl-draft-sendlog*")) - (filename (expand-file-name wl-draft-sendlog-filename + (with-temp-buffer + (let* ((filename (expand-file-name wl-draft-sendlog-filename elmo-msgdb-dir)) (filesize (nth 7 (file-attributes filename))) (server (if server (concat " server=" server) "")) @@ -756,18 +778,15 @@ Reply to author if WITH-ARG is non-nil." "")) (id (if id (concat " id=" id) "")) (time (wl-sendlog-time))) - (set-buffer tmp-buf) - (erase-buffer) (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 (> filesize wl-draft-sendlog-max-size)) (rename-file filename (concat filename ".old") t)) (if (file-writable-p filename) - (write-region (point-min) (point-max) - filename t 'no-msg) - (message (format "%s is not writable." filename))) - (kill-buffer tmp-buf))))) + (write-region-as-binary (point-min) (point-max) + filename t 'no-msg) + (message (format "%s is not writable." filename))))))) (defun wl-draft-get-header-delimiter (&optional delete) ;; If DELETE is non-nil, replace the header delimiter with a blank line @@ -802,10 +821,10 @@ to find out how to use this." (0 (progn (wl-draft-set-sent-message 'mail 'sent) (wl-draft-write-sendlog 'ok 'qmail nil (list to) id))) - (1 (error "qmail-inject reported permanent failure")) - (111 (error "qmail-inject reported transient failure")) + (1 (error "`qmail-inject' reported permanent failure")) + (111 (error "`qmail-inject' reported transient failure")) ;; should never happen - (t (error "qmail-inject reported unknown failure")))))) + (t (error "`qmail-inject' reported unknown failure")))))) (defun wl-draft-parse-msg-id-list-string (string) "Get msg-id list from STRING." @@ -879,7 +898,7 @@ 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 '("to" "cc" "bcc")) (resent-fields '("resent-to" "resent-cc" "resent-bcc")) (case-fold-search t) addrs recipients) @@ -977,17 +996,18 @@ non-nil." (require 'elmo-pop3) (condition-case () (let ((session (elmo-pop3-get-session - (list 'pop3 - (or wl-pop-before-smtp-user - elmo-pop3-default-user) - (or wl-pop-before-smtp-authenticate-type - elmo-pop3-default-authenticate-type) - (or wl-pop-before-smtp-server - elmo-pop3-default-server) - (or wl-pop-before-smtp-port - elmo-pop3-default-port) - (or wl-pop-before-smtp-stream-type - elmo-pop3-default-stream-type))))) + (luna-make-entity + 'elmo-pop3-folder + :user (or wl-pop-before-smtp-user + elmo-pop3-default-user) + :server (or wl-pop-before-smtp-server + elmo-pop3-default-server) + :port (or wl-pop-before-smtp-port + 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))))) (when session (elmo-network-close-session session))) (error)) (wl-draft-send-mail-with-smtp)) @@ -1110,14 +1130,14 @@ If FORCE-MSGID, ignore 'wl-insert-message-id'." (defun wl-draft-send (&optional kill-when-done mes-string) "Send current draft message. -If optional argument is non-nil, current draft buffer is killed" +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) (run-hooks 'wl-draft-send-hook) (when (or (not wl-interactive-send) - (y-or-n-p "Send current draft. OK?")) + (y-or-n-p "Do you really want to send current draft? ")) (let ((send-mail-function 'wl-draft-raw-send) (editing-buffer (current-buffer)) (sending-buffer (wl-draft-generate-clone-buffer @@ -1183,7 +1203,7 @@ If optional argument is non-nil, current draft buffer is killed" (let ((editing-buffer (current-buffer))) (wl-draft-hide editing-buffer) (kill-buffer editing-buffer))) - + (defun wl-draft-send-and-exit () "Send current draft message and kill it." (interactive) @@ -1226,7 +1246,7 @@ If optional argument is non-nil, current draft buffer is killed" (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")) + (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) @@ -1250,7 +1270,7 @@ If optional argument is non-nil, current draft buffer is killed" (tembuf (generate-new-buffer " fcc output")) (case-fold-search t) beg end) - (or (markerp header-end) (error "header-end must be a marker")) + (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))) @@ -1274,7 +1294,7 @@ If optional argument is non-nil, current draft buffer is killed" (if (elmo-folder-append-buffer (wl-folder-get-elmo-folder (eword-decode-string (car fcc-list))) - id) + (not wl-fcc-force-as-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))))) @@ -1309,15 +1329,15 @@ If optional argument is non-nil, current draft buffer is killed" (defun wl-draft (&optional to subject in-reply-to cc references newsgroups mail-followup-to content-type content-transfer-encoding - body edit-again summary-buf from) + body edit-again summary-buf from parent-folder) "Write and send mail/news message with Wanderlust." (interactive) - (unless (featurep 'wl) - (require 'wl)) + (require 'wl) (unless wl-init (wl-load-profile) (wl-folder-init) - (elmo-init)) + (elmo-init) + (wl-plugged-init t)) (wl-init) ; returns immediately if already initialized. (if (interactive-p) (setq summary-buf (wl-summary-get-buffer (wl-summary-buffer-folder-name)))) @@ -1350,8 +1370,11 @@ If optional argument is non-nil, current draft buffer is killed" (delete-other-windows)) (auto-save-mode -1) (wl-draft-mode) - (setq truncate-lines wl-message-truncate-lines) + (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-draft-parent-folder parent-folder) (if (stringp (or from wl-from)) (insert "From: " (or from wl-from) "\n")) (and (or (interactive-p) @@ -1423,11 +1446,11 @@ If optional argument is non-nil, current draft buffer is killed" (run-hooks 'wl-mail-setup-hook)) (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)) - (mail-position-on-field "To")) - (t - (goto-char (point-max)))) + (mail-position-on-field "Subject")) + ((and (interactive-p) (null to)) + (mail-position-on-field "To")) + (t + (goto-char (point-max)))) (setq wl-draft-buffer-cur-summary-buffer (or summary-buf (get-buffer wl-summary-buffer-name))) @@ -1459,17 +1482,17 @@ If optional argument is non-nil, current draft buffer is killed" (elmo-nntp-default-stream-type (or wl-nntp-posting-stream-type elmo-nntp-default-stream-type))) (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)) + (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)) (wl-draft-set-sent-message 'news 'sent) (wl-draft-write-sendlog 'ok 'nntp elmo-nntp-default-server - (std11-field-body "Newsgroups") - (std11-field-body "Message-ID"))))) + (std11-field-body "Newsgroups") + (std11-field-body "Message-ID"))))) (defun wl-draft-generate-clone-buffer (name &optional local-variables) - "generate clone of current buffer named NAME." + "Generate clone of current buffer named NAME." (let ((editing-buffer (current-buffer))) (save-excursion (set-buffer (generate-new-buffer name)) @@ -1554,6 +1577,18 @@ If optional argument is non-nil, current draft buffer is killed" (wl-draft-config-body-goto-header) (if content (insert (concat (eval content) "\n")))) +(defun wl-draft-config-sub-header-top (content) + (goto-char (point-min)) + (if content (insert (concat (eval content) "\n")))) + +(defun wl-draft-config-sub-part-top (content) + (goto-char (mime-edit-content-beginning)) + (if content (insert (concat (eval content) "\n")))) + +(defun wl-draft-config-sub-part-bottom (content) + (goto-char (mime-edit-content-end)) + (if content (insert (concat (eval content) "\n")))) + (defsubst wl-draft-config-sub-file (content) (let ((coding-system-for-read wl-cs-autoconv) (file (expand-file-name (eval content)))) @@ -1798,7 +1833,9 @@ If optional argument is non-nil, current draft buffer is killed" "Flush draft queue." (interactive) (let* ((queue-folder (wl-folder-get-elmo-folder wl-queue-folder)) - (msgs2 (elmo-folder-list-messages queue-folder)) + (msgs2 (progn + (elmo-folder-open-internal queue-folder) + (elmo-folder-list-messages queue-folder))) (i 0) (performed 0) (wl-draft-queue-flushing t) @@ -1818,7 +1855,7 @@ If optional argument is non-nil, current draft buffer is killed" (setq msgs2 (cdr msgs2))) (when (> (setq len (length msgs)) 0) (if (elmo-y-or-n-p (format - "%d message(s) are in the sending queue. Send now?" + "%d message(s) are in the sending queue. Send now? " len) (not elmo-dop-flush-confirm) t) (progn @@ -1857,6 +1894,7 @@ If optional argument is non-nil, current draft buffer is killed" (kill-buffer buffer) (message "%d message(s) are sent." performed))) (message "%d message(s) are remained to be sent." len)) + (elmo-folder-close queue-folder) len))) (defun wl-jump-to-draft-buffer (&optional arg) @@ -1924,11 +1962,11 @@ If optional argument is non-nil, current draft buffer is killed" "Insert HEADER-NAME w/ value HEADER-VALUE into a message." ;; it seems like overriding existing headers is acceptable -- should ;; we provide an option? - + ;; plan was: unfold header (might be folded), remove existing value, insert ;; new value ;; wl doesn't seem to fold header lines yet anyway :-) - + (let ((kill-whole-line t) end-of-line) (mail-position-on-field (capitalize header-name)) @@ -1964,8 +2002,8 @@ been implemented yet. Partial support for SWITCH-FUNCTION now supported." ;; 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)) + (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))