(make-variable-buffer-local 'wl-draft-reply-buffer)
(make-variable-buffer-local 'wl-draft-parent-folder)
-(defsubst wl-smtp-password-key (user mechnism server)
+(defsubst wl-smtp-password-key (user mechanism server)
(format "SMTP:%s/%s@%s"
- user mechnism server))
+ user mechanism server))
(defmacro wl-smtp-extension-bind (&rest body)
(` (let* ((smtp-sasl-mechanisms
(not (elmo-plugged-p)))
(wl-draft-set-sent-message 'mail 'unplugged)
;; send the message
+ (run-hooks 'wl-mail-send-pre-hook) ;; X-PGP-Sig, Cancel-Lock
(let ((id (std11-field-body "Message-ID"))
(to (std11-field-body "To")))
(case
(goto-char (1+ delimline))
(if (eval mail-mailer-swallows-blank-line)
(newline))
-;;; (run-hooks 'wl-mail-send-pre-hook)
+ (run-hooks 'wl-mail-send-pre-hook) ;; X-PGP-Sig, Cancel-Lock
(if mail-interactive
(save-excursion
(set-buffer errbuf)
(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)
;; 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
+;;; (run-hooks 'wl-mail-send-pre-hook) ;; X-PGP-Sig, Cancel-Lock
(wl-draft-dispatch-message)
(when kill-when-done
;; hide editing-buffer.
(kill-buffer sending-buffer))))))
(defun wl-draft-save ()
- "Save current draft."
+ "Save current draft.
+Derived from `message-save-drafts' in T-gnus."
(interactive)
- (save-buffer)
- (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))
+ (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
+ (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))
+ (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
+ '((eword-encode-unstructured-field-body))))
+ (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))
+ (message "(No changes need to be saved)")))
(defun wl-draft-mimic-kill-buffer ()
"Kill the current (draft) buffer with query."
(let ((wl-interactive-send t))
(wl-draft-send-and-exit)))
-(defun wl-draft-delete-field (field &optional delimline)
- (wl-draft-delete-fields (regexp-quote field) delimline))
+(defun wl-draft-delete-field (field &optional delimline replace)
+ (wl-draft-delete-fields (regexp-quote field) delimline replace))
-(defun wl-draft-delete-fields (regexp &optional delimline)
+(defun wl-draft-delete-fields (field &optional delimline replace)
(save-restriction
(unless delimline
+ (goto-char (point-min))
(if (search-forward "\n\n" nil t)
(setq delimline (point))
(setq delimline (point-max))))
(narrow-to-region (point-min) delimline)
(goto-char (point-min))
- (let ((regexp (concat "^" regexp ":"))
- (case-fold-search t)
- last)
+ (let ((regexp (concat "^" field ":"))
+ (case-fold-search t))
(while (not (eobp))
(if (looking-at regexp)
(progn
(forward-line 1)
(if (re-search-forward "^[^ \t]" nil t)
(goto-char (match-beginning 0))
- (point-max)))))
+ (point-max))))
+ (if replace
+ (insert (concat field ": " replace "\n"))))
(forward-line 1)
(if (re-search-forward "^[^ \t]" nil t)
(goto-char (match-beginning 0))
(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
(wl-folder-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))))
- (let ((draft-folder (wl-folder-get-elmo-folder wl-draft-folder))
- buf-name file-name num wl-demo change-major-mode-hook)
+ (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)))
+ (setq header-alist (append header-alist
+ (wl-draft-default-headers)
+ (if body (list "" body))))
+ (wl-draft-create-contents header-alist)
+ (if edit-again
+ (wl-draft-decode-body
+ content-type content-transfer-encoding))
+ (wl-draft-insert-mail-header-separator)
+ (wl-draft-prepare-edit)
+ (if (interactive-p)
+ (run-hooks 'wl-mail-setup-hook))
+
+ (goto-char (point-min))
+ (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))))
+ 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
(buffer-name)))
(rename-buffer (concat wl-draft-folder "/" (int-to-string num))))
(if (or (eq wl-draft-reply-buffer-style 'full)
- (eq this-command 'wl-draft)
- (eq this-command 'wl-summary-write)
- (eq this-command 'wl-summary-write-current-folder))
+ full)
(delete-other-windows))
(auto-save-mode -1)
(wl-draft-mode)
(setq truncate-lines wl-draft-truncate-lines)
(setq wl-sent-message-via nil)
(setq wl-sent-message-queued 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)
- (eq this-command 'wl-summary-write)
- to)
- (insert "To: " (or to "") "\n"))
- (and cc (insert "Cc: " (or cc "") "\n"))
- (insert "Subject: " (or subject "") "\n")
- (and newsgroups (insert "Newsgroups: " newsgroups "\n"))
- (and mail-followup-to (insert "Mail-Followup-To: " mail-followup-to "\n"))
- (and wl-insert-mail-reply-to
- (insert "Mail-Reply-To: "
- (wl-address-header-extract-address
- wl-from) "\n"))
- (and in-reply-to (insert "In-Reply-To: " in-reply-to "\n"))
- (and references (insert "References: " references "\n"))
- (insert (funcall wl-generate-mailer-string-function) "\n")
(setq wl-draft-buffer-file-name file-name)
- (if mail-default-reply-to
- (insert "Reply-To: " mail-default-reply-to "\n"))
- (wl-draft-insert-ccs "Bcc: " (or wl-bcc
- (and mail-self-blind (user-login-name))))
- (wl-draft-insert-ccs "Fcc: " wl-fcc)
- (if wl-organization
- (insert "Organization: " wl-organization "\n"))
- (and wl-auto-insert-x-face
- (file-exists-p wl-x-face-file)
- (wl-draft-insert-x-face-field-here))
- (if mail-default-headers
- (insert mail-default-headers))
- (if (not (= (preceding-char) ?\n))
- (insert ?\n))
- (if edit-again
- (let (start)
- (setq start (point))
- (when content-type
- (insert "Content-type: " content-type "\n"))
- (when content-transfer-encoding
- (insert "Content-Transfer-Encoding: " content-transfer-encoding "\n"))
- (if (or content-type content-transfer-encoding)
- (insert "\n"))
- (and body (insert body))
- (save-restriction
- (narrow-to-region start (point))
- (and edit-again
- (wl-draft-decode-message-in-buffer))
- (widen)
- (goto-char start)
- (put-text-property (point)
- (progn
- (insert mail-header-separator "\n")
- (1- (point)))
- 'category 'mail-header-separator)))
- (put-text-property (point)
- (progn
- (insert mail-header-separator "\n")
- (1- (point)))
- 'category 'mail-header-separator)
- (and body (insert body)))
- (as-binary-output-file
- (write-region (point-min)(point-max) wl-draft-buffer-file-name
- nil t))
+ (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))
+
+(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
+"
+ (unless (eq major-mode 'wl-draft-mode)
+ (error "wl-draft-create-header must be use in wl-draft-mode."))
+ (let ((halist header-alist)
+ field value)
+ (while halist
+ (cond
+ ;; function
+ ((functionp (car halist)) (funcall (car halist)))
+ ;; string
+ ((stringp (car halist)) (insert (car halist) "\n"))
+ ;; cons
+ ((consp (car halist))
+ (setq field (car (car halist)))
+ (setq value (cdr (car halist)))
+ (cond
+ ((functionp field) (apply field value))
+ ((stringp field)
+ (cond
+ ((stringp value) (insert field value "\n"))
+ ((functionp value) (insert field (funcall value) "\n"))
+ ((not value))
+ (t
+ (debug))))
+ ;;
+ ((not field))
+ (t
+ (debug))
+ )))
+ (setq halist (cdr halist)))))
+
+(defun wl-draft-prepare-edit ()
+ (unless (eq major-mode 'wl-draft-mode)
+ (error "wl-draft-create-header must be use in wl-draft-mode."))
+ (let (change-major-mode-hook)
(wl-draft-editor-mode)
+ (add-hook 'local-write-file-hooks 'wl-draft-save)
(wl-draft-overload-functions)
(wl-highlight-headers 'for-draft)
- (goto-char (point-min))
- (setq wl-draft-config-exec-flag t)
- (if (interactive-p)
- (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))))
- (setq wl-draft-buffer-cur-summary-buffer (or summary-buf
- (get-buffer
- wl-summary-buffer-name)))
- buf-name))
+ (wl-draft-save)
+ (clear-visited-file-modtime)))
+
+(defun wl-draft-decode-header ()
+ (save-excursion
+ (std11-narrow-to-header)
+ (wl-draft-decode-message-in-buffer)
+ (widen)))
+
+(defun wl-draft-decode-body (&optional content-type content-transfer-encoding)
+ (let ((content-type
+ (or content-type
+ (std11-field-body "content-type")))
+ (content-transfer-encoding
+ (or content-transfer-encoding
+ (std11-field-body "content-transfer-encoding")))
+ delimline)
+ (save-excursion
+ (std11-narrow-to-header)
+ (wl-draft-delete-field "content-type")
+ (wl-draft-delete-field "content-transfer-encoding")
+ (goto-char (point-max))
+ (setq delimline (point-marker))
+ (widen)
+ (narrow-to-region delimline (point-max))
+ (goto-char (point-min))
+ (when content-type
+ (insert "Content-type: " content-type "\n"))
+ (when content-transfer-encoding
+ (insert "Content-Transfer-Encoding: " content-transfer-encoding "\n"))
+ (wl-draft-decode-message-in-buffer)
+ (goto-char (point-min))
+ (unless (re-search-forward "^$" (point-at-eol) t)
+ (insert "\n"))
+ (widen)
+ delimline)))
+
+;;; subroutine for wl-draft-create-contents
+;;; must be used in wl-draft-mode
+(defun wl-draft-check-new-line ()
+ (if (not (= (preceding-char) ?\n))
+ (insert ?\n)))
(defsubst wl-draft-insert-ccs (str cc)
(let ((field
(mapcar 'downcase wl-subscribed-mailing-list)))))
(insert str field "\n"))))
+(defsubst 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)
+ (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)
+ (save-excursion
+ (if delimline
+ (goto-char delimline)
+ (goto-char (point-min))
+ (if (search-forward "\n\n" nil t)
+ (delete-backward-char 1)
+ (goto-char (point-max))))
+ (wl-draft-check-new-line)
+ (put-text-property (point)
+ (progn
+ (insert mail-header-separator "\n")
+ (1- (point)))
+ 'category 'mail-header-separator)))
+
+;;;;;;;;;;;;;;;;
+
(defun wl-draft-elmo-nntp-send ()
(let ((elmo-nntp-post-pre-hook wl-news-send-pre-hook)
(elmo-nntp-default-user
(defun wl-draft-reedit (number)
(let ((draft-folder (wl-folder-get-elmo-folder wl-draft-folder))
(wl-draft-reedit t)
- buf-name file-name change-major-mode-hook)
+ 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))
- (setq buf-name (find-file-noselect file-name))
- (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 "/" (buffer-name))))
- (auto-save-mode -1)
- (wl-draft-mode)
- (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))
- (or (re-search-forward "\n\n" nil t)
- (search-forward (concat mail-header-separator "\n") nil t))
- (write-region (point-min)(point-max) wl-draft-buffer-file-name
- nil t)
- (wl-draft-overload-functions)
- (wl-draft-editor-mode)
- (wl-highlight-headers 'for-draft)
- (run-hooks 'wl-draft-reedit-hook)
- (goto-char (point-max))
- buf-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 (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)
+ (setq buffer-file-name file-name)
+ (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)
+ (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)
+ (add-hook 'local-write-file-hooks 'wl-draft-save)
+ (wl-highlight-headers 'for-draft)
+ (run-hooks 'wl-draft-reedit-hook)
+ (goto-char (point-max))
+ buffer)))
(defmacro wl-draft-body-goto-top ()
(` (progn
buf draft-bufs)
(while bufs
(if (and
- (setq buf (buffer-file-name (car bufs)))
+ (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)))
projects / elisp / wanderlust.git / blobdiff