1 ;;; wl-draft.el -- Message draft mode for Wanderlust.
3 ;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
4 ;; Copyright (C) 1998,1999,2000 Masahiro MURATA <muse@ba2.so-net.ne.jp>
6 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
7 ;; Masahiro MURATA <muse@ba2.so-net.ne.jp>
8 ;; Keywords: mail, net news
10 ;; This file is part of Wanderlust (Yet Another Message Interface on Emacsen).
12 ;; This program is free software; you can redistribute it and/or modify
13 ;; it under the terms of the GNU General Public License as published by
14 ;; the Free Software Foundation; either version 2, or (at your option)
17 ;; This program is distributed in the hope that it will be useful,
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;; GNU General Public License for more details.
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with GNU Emacs; see the file COPYING. If not, write to the
24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25 ;; Boston, MA 02111-1307, USA.
35 (require 'wl-template)
37 (condition-case nil (require 'timezone) (error nil))
41 (defvar x-face-add-x-face-version-header)
42 (defvar mail-reply-buffer)
43 (defvar mail-from-style)
47 (defalias-maybe 'x-face-insert 'ignore)
48 (defalias-maybe 'x-face-insert-version-header 'ignore)
49 (defalias-maybe 'wl-init 'ignore)
50 (defalias-maybe 'wl-draft-mode 'ignore))
52 (defvar wl-draft-buf-name "Draft")
53 (defvar wl-caesar-region-func nil)
54 (defvar wl-draft-cite-func 'wl-default-draft-cite)
55 (defvar wl-draft-buffer-file-name nil)
56 (defvar wl-draft-field-completion-list nil)
57 (defvar wl-draft-verbose-send t)
58 (defvar wl-draft-verbose-msg nil)
59 (defvar wl-draft-queue-flushing nil)
60 (defvar wl-draft-config-variables nil)
61 (defvar wl-draft-config-exec-flag t)
62 (defvar wl-draft-buffer-cur-summary-buffer nil)
63 (defvar wl-draft-clone-local-variable-regexp "^\\(wl\\|mime\\)")
64 (defvar wl-draft-sendlog-filename "sendlog")
65 (defvar wl-draft-queue-save-filename "qinfo")
66 (defvar wl-draft-config-save-filename "config")
67 (defvar wl-draft-queue-flush-send-func 'wl-draft-dispatch-message)
68 (defvar wl-sent-message-via nil)
69 (defvar wl-sent-message-modified nil)
70 (defvar wl-draft-fcc-list nil)
71 (defvar wl-draft-reedit nil)
72 (defvar wl-draft-reply-buffer nil)
73 (defvar wl-draft-forward nil)
75 (defvar wl-draft-config-sub-func-alist
76 '((body . wl-draft-config-sub-body)
77 (top . wl-draft-config-sub-top)
78 (bottom . wl-draft-config-sub-bottom)
79 (header . wl-draft-config-sub-header)
80 (body-file . wl-draft-config-sub-body-file)
81 (top-file . wl-draft-config-sub-top-file)
82 (bottom-file . wl-draft-config-sub-bottom-file)
83 (header-file . wl-draft-config-sub-header-file)
84 (template . wl-draft-config-sub-template)
85 (x-face . wl-draft-config-sub-x-face)))
87 (make-variable-buffer-local 'wl-draft-buffer-file-name)
88 (make-variable-buffer-local 'wl-draft-buffer-cur-summary-buffer)
89 (make-variable-buffer-local 'wl-draft-config-variables)
90 (make-variable-buffer-local 'wl-draft-config-exec-flag)
91 (make-variable-buffer-local 'wl-sent-message-via)
92 (make-variable-buffer-local 'wl-draft-fcc-list)
93 (make-variable-buffer-local 'wl-draft-reply-buffer)
95 (defmacro wl-smtp-extension-bind (&rest body)
96 (` (let* ((smtp-sasl-mechanisms
97 (if wl-smtp-authenticate-type
99 (if (listp wl-smtp-authenticate-type)
100 wl-smtp-authenticate-type
101 (list wl-smtp-authenticate-type)))))
102 (smtp-use-sasl (and smtp-sasl-mechanisms t))
103 (smtp-use-starttls (eq wl-smtp-connection-type 'starttls))
104 smtp-sasl-user-name smtp-sasl-properties sasl-read-passphrase)
105 (if (and (string= (car smtp-sasl-mechanisms) "DIGEST-MD5")
107 (string-match "^\\([^@]*\\)@\\([^@]*\\)"
108 wl-smtp-posting-user))
109 (setq smtp-sasl-user-name (match-string 1 wl-smtp-posting-user)
110 smtp-sasl-properties (list 'realm
111 (match-string 2 wl-smtp-posting-user)))
112 (setq smtp-sasl-user-name wl-smtp-posting-user
113 smtp-sasl-properties nil))
114 (setq sasl-read-passphrase
123 (defun wl-draft-insert-date-field ()
125 (insert "Date: " (wl-make-date-string) "\n"))
127 (defun wl-draft-insert-from-field ()
129 ;; Put the "From:" field in unless for some odd reason
130 ;; they put one in themselves.
131 (let* ((login (or user-mail-address (user-login-name)))
132 (fullname (user-full-name)))
133 (cond ((eq mail-from-style 'angles)
134 (insert "From: " fullname)
135 (let ((fullname-start (+ (point-min) (length "From: ")))
136 (fullname-end (point-marker)))
137 (goto-char fullname-start)
138 ;; Look for a character that cannot appear unquoted
139 ;; according to RFC 822.
140 (if (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]"
143 ;; Quote fullname, escaping specials.
144 (goto-char fullname-start)
146 (while (re-search-forward "[\"\\]"
148 (replace-match "\\\\\\&" t))
150 (insert " <" login ">\n"))
151 ((eq mail-from-style 'parens)
152 (insert "From: " login " (")
153 (let ((fullname-start (point)))
155 (let ((fullname-end (point-marker)))
156 (goto-char fullname-start)
157 ;; RFC 822 says \ and nonmatching parentheses
158 ;; must be escaped in comments.
159 ;; Escape every instance of ()\ ...
160 (while (re-search-forward "[()\\]" fullname-end 1)
161 (replace-match "\\\\\\&" t))
162 ;; ... then undo escaping of matching parentheses,
163 ;; including matching nested parentheses.
164 (goto-char fullname-start)
165 (while (re-search-forward
166 "\\(\\=\\|[^\\]\\(\\\\\\\\\\)*\\)\\\\(\\(\\([^\\]\\|\\\\\\\\\\)*\\)\\\\)"
168 (replace-match "\\1(\\3)" t)
169 (goto-char fullname-start))))
171 ((not mail-from-style)
172 (insert "From: " login "\n")))))
174 (defun wl-draft-insert-x-face-field ()
175 "Insert X-Face header."
177 (unless (file-exists-p wl-x-face-file)
178 (error "File %s does not exist" wl-x-face-file))
179 (beginning-of-buffer)
180 (search-forward mail-header-separator nil t)
182 (wl-draft-insert-x-face-field-here)
183 (run-hooks 'wl-draft-insert-x-face-field-hook)) ; highlight it if you want.
185 (defun wl-draft-insert-x-face-field-here ()
186 "Insert X-Face field at point."
187 (let ((x-face-string (elmo-get-file-string wl-x-face-file)))
188 (when (string-match "^[ \t]*" x-face-string)
189 (setq x-face-string (substring x-face-string (match-end 0))))
190 (insert "X-Face: " x-face-string))
191 (when (not (= (preceding-char) ?\n)) ; for chomped (choped) x-face-string
193 ;; Insert X-Face-Version: field
194 (when (and (fboundp 'x-face-insert-version-header)
195 (boundp 'x-face-add-x-face-version-header)
196 x-face-add-x-face-version-header)
197 (x-face-insert-version-header)))
199 (defun wl-draft-setup ()
200 (let ((field wl-draft-fields)
203 (setq ret-val (append ret-val
204 (list (cons (concat (car field) " ")
205 (concat (car field) " ")))))
206 (setq field (cdr field)))
207 (setq wl-draft-field-completion-list ret-val)))
209 (defun wl-draft-make-mail-followup-to (recipients)
210 (if (elmo-list-member
211 (or wl-user-mail-address-list
212 (list (wl-address-header-extract-address wl-from)))
214 (let ((rlist (elmo-list-delete
215 (or wl-user-mail-address-list
216 (list (wl-address-header-extract-address wl-from)))
217 (copy-sequence recipients))))
218 (if (elmo-list-member rlist (mapcar 'downcase
219 wl-subscribed-mailing-list))
221 (append rlist (list (wl-address-header-extract-address
225 (defun wl-draft-delete-myself-from-cc (to cc)
226 (let ((myself (or wl-user-mail-address-list
227 (list (wl-address-header-extract-address wl-from)))))
228 (cond (wl-draft-always-delete-myself ; always-delete option
229 (elmo-list-delete myself cc))
230 ((elmo-list-member (append to cc) ; subscribed mailing-list
231 (mapcar 'downcase wl-subscribed-mailing-list))
232 (elmo-list-delete myself cc))
235 (defun wl-draft-forward (original-subject summary-buf)
237 (with-current-buffer (wl-message-get-original-buffer)
238 (setq references (nconc
239 (std11-field-bodies '("References" "In-Reply-To"))
240 (list (std11-field-body "Message-Id"))))
241 (setq references (delq nil references)
242 references (mapconcat 'identity references " ")
243 references (wl-draft-parse-msg-id-list-string references)
244 references (wl-delete-duplicates references)
245 references (when references
246 (mapconcat 'identity references "\n\t"))))
247 (wl-draft "" (concat "Forward: " original-subject)
248 nil nil references nil nil nil nil nil nil summary-buf))
249 (goto-char (point-max))
250 (wl-draft-insert-message)
251 (mail-position-on-field "To"))
253 (defun wl-draft-strip-subject-re (subject)
254 "Remove \"Re:\" from subject lines. Shamelessly copied from Gnus"
255 (if (string-match wl-subject-prefix-regexp subject)
256 (substring subject (match-end 0))
259 (defun wl-draft-reply-list-symbol (with-arg)
260 "Return symbol `wl-draft-reply-*-argument-list' match condition.
261 Check WITH-ARG and From: field."
262 (if (wl-address-user-mail-address-p (or (elmo-field-body "From") ""))
264 'wl-draft-reply-myself-with-argument-list
265 'wl-draft-reply-myself-without-argument-list)
267 'wl-draft-reply-with-argument-list
268 'wl-draft-reply-without-argument-list)))
270 (defun wl-draft-reply (buf with-arg summary-buf)
271 "Reply to BUF buffer message.
272 Reply to author if WITH-ARG is non-nil."
275 to mail-followup-to cc subject in-reply-to references newsgroups
276 from to-alist cc-alist decoder)
278 (setq r-list (symbol-value (wl-draft-reply-list-symbol with-arg)))
281 (when (let ((condition (car (car r-list))))
282 (cond ((stringp condition)
283 (std11-field-body condition))
287 (if (not (std11-field-body (car condition)))
289 (setq condition (cdr condition)))
292 (funcall condition))))
293 (let ((r-to-list (nth 0 (cdr (car r-list))))
294 (r-cc-list (nth 1 (cdr (car r-list))))
295 (r-ng-list (nth 2 (cdr (car r-list)))))
296 (when (and (member "Followup-To" r-ng-list)
297 (string= (std11-field-body "Followup-To") "poster"))
298 (setq r-to-list (cons "From" r-to-list))
299 (setq r-ng-list (delete "Followup-To" (copy-sequence r-ng-list))))
300 (setq to (wl-concat-list (cons to
301 (elmo-multiple-fields-body-list
304 (setq cc (wl-concat-list (cons cc
305 (elmo-multiple-fields-body-list
308 (setq newsgroups (wl-concat-list (cons newsgroups
313 (setq r-list (cdr r-list)))
314 (error "No match field: check your `%s'"
315 (symbol-name (wl-draft-reply-list-symbol with-arg))))
316 (setq subject (std11-field-body "Subject"))
317 (setq to (wl-parse-addresses to)
318 cc (wl-parse-addresses cc))
319 (with-temp-buffer ; to keep raw buffer unibyte.
320 (elmo-set-buffer-multibyte default-enable-multibyte-characters)
321 (setq decoder (mime-find-field-decoder 'Subject 'plain))
322 (setq subject (if (and subject decoder)
323 (funcall decoder subject) subject))
327 (setq decoder (mime-find-field-decoder 'To 'plain))
328 (cons (nth 1 (std11-extract-address-components addr))
329 (if decoder (funcall decoder addr) addr)))
334 (setq decoder (mime-find-field-decoder 'Cc 'plain))
335 (cons (nth 1 (std11-extract-address-components addr))
336 (if decoder (funcall decoder addr) addr)))
338 (and wl-reply-subject-prefix
339 (setq subject (concat wl-reply-subject-prefix
340 (wl-draft-strip-subject-re
342 (setq in-reply-to (std11-field-body "Message-Id"))
343 (setq references (nconc
344 (std11-field-bodies '("References" "In-Reply-To"))
346 (setq to (delq nil (mapcar 'car to-alist)))
347 (setq cc (delq nil (mapcar 'car cc-alist)))
348 ;; if subscribed mailing list is contained in cc or to
349 ;; and myself is contained in cc,
350 ;; delete myself from cc.
351 (setq cc (wl-draft-delete-myself-from-cc to cc))
352 (when wl-insert-mail-followup-to
353 (setq mail-followup-to
354 (wl-draft-make-mail-followup-to (append to cc)))
355 (setq mail-followup-to (wl-delete-duplicates mail-followup-to nil t)))
356 (setq newsgroups (wl-parse newsgroups
357 "[ \t\f\r\n,]*\\([^ \t\f\r\n,]+\\)")
358 newsgroups (wl-delete-duplicates newsgroups)
359 newsgroups (if newsgroups (mapconcat 'identity newsgroups ",")))
360 (setq to (wl-delete-duplicates to nil t))
361 (setq cc (wl-delete-duplicates
362 (append (wl-delete-duplicates cc nil t)
363 to (copy-sequence to))
365 (and to (setq to (mapconcat
367 (if wl-draft-reply-use-address-with-full-name
368 (or (cdr (assoc addr to-alist)) addr)
371 (and cc (setq cc (mapconcat
373 (if wl-draft-reply-use-address-with-full-name
374 (or (cdr (assoc addr cc-alist)) addr)
377 (and mail-followup-to
378 (setq mail-followup-to
381 (if wl-draft-reply-use-address-with-full-name
382 (or (cdr (assoc addr (append to-alist cc-alist))) addr)
384 mail-followup-to ",\n\t")))
385 (and (null to) (setq to cc cc nil))
386 (setq references (delq nil references)
387 references (mapconcat 'identity references " ")
388 references (wl-draft-parse-msg-id-list-string references)
389 references (wl-delete-duplicates references)
390 references (if references
391 (mapconcat 'identity references "\n\t")))
393 to subject in-reply-to cc references newsgroups mail-followup-to
394 nil nil nil nil summary-buf)
395 (setq wl-draft-reply-buffer buf))
396 (run-hooks 'wl-reply-hook))
398 (defun wl-draft-add-references ()
399 (let* ((mes-id (save-excursion
400 (set-buffer mail-reply-buffer)
401 (std11-field-body "message-id")))
402 (ref (std11-field-body "References"))
403 (ref-list nil) (st nil))
404 (when (and mes-id ref)
405 (while (string-match "<[^>]+>" ref st)
407 (cons (substring ref (match-beginning 0) (setq st (match-end 0)))
410 (member mes-id ref-list))
414 (when (mail-position-on-field "References")
416 (while (looking-at "^[ \t]")
418 (setq mes-id (concat "\t" mes-id "\n")))
422 (defun wl-draft-yank-from-mail-reply-buffer (decode-it
423 &optional ignored-fields)
426 (narrow-to-region (point)(point))
429 (set-buffer mail-reply-buffer)
431 (decode-mime-charset-region (point-min) (point-max)
433 (buffer-substring-no-properties
434 (point-min) (point-max))))
436 (goto-char (point-min))
437 (wl-draft-delete-fields ignored-fields))
438 (goto-char (point-max))
439 (push-mark (point) nil t)
440 (goto-char (point-min)))
442 (cond (mail-citation-hook (run-hooks 'mail-citation-hook))
443 (mail-yank-hooks (run-hooks 'mail-yank-hooks))
444 (t (and wl-draft-cite-func
445 (funcall wl-draft-cite-func)))) ; default cite
446 (run-hooks 'wl-draft-cited-hook)
447 (when (and wl-draft-add-references
448 (wl-draft-add-references))
449 (wl-highlight-headers 'for-draft)) ; highlight when added References:
450 (when wl-highlight-body-too
451 (wl-highlight-body-region beg (point-max)))))
453 (defun wl-draft-confirm ()
454 "Confirm send message."
457 (cond ((and (wl-message-mail-p) (wl-message-news-p))
458 "Send current draft as Mail and News? ")
459 ((wl-message-mail-p) "Send current draft as Mail? ")
460 ((wl-message-news-p) "Send current draft as News? "))))
462 (defun wl-message-field-exists-p (field)
463 "If FIELD exist and FIELD value is not empty, return non-nil."
464 (let ((value (std11-field-body field)))
466 (not (string= value "")))))
468 (defun wl-message-news-p ()
469 "If exist valid Newsgroups field, return non-nil."
470 (std11-field-body "Newsgroups"))
472 (defun wl-message-mail-p ()
473 "If exist To, Cc or Bcc field, return non-nil."
474 (or (wl-message-field-exists-p "To")
475 (wl-message-field-exists-p "Resent-to")
476 (wl-message-field-exists-p "Cc")
477 (wl-message-field-exists-p "Bcc")
478 ;;; This may be needed..
479 ;;; (wl-message-field-exists-p "Fcc")
482 (defun wl-draft-open-file (&optional file)
483 "Open FILE for edit."
485 ;;;(interactive "*fFile to edit: ")
486 (wl-draft-edit-string (elmo-get-file-string
488 (read-file-name "File to edit: "
489 (or wl-tmp-dir "~/"))))))
491 (defun wl-draft-edit-string (string)
492 (let ((cur-buf (current-buffer))
493 (tmp-buf (get-buffer-create " *wl-draft-edit-string*"))
494 to subject in-reply-to cc references newsgroups mail-followup-to
495 content-type content-transfer-encoding from
496 body-beg buffer-read-only)
500 (setq to (std11-field-body "To"))
503 (decode-mime-charset-string
506 (setq subject (std11-field-body "Subject"))
507 (setq subject (and subject
509 (decode-mime-charset-string
512 (setq from (std11-field-body "From")
515 (decode-mime-charset-string
518 (setq in-reply-to (std11-field-body "In-Reply-To"))
519 (setq cc (std11-field-body "Cc"))
522 (decode-mime-charset-string
525 (setq references (std11-field-body "References"))
526 (setq newsgroups (std11-field-body "Newsgroups"))
527 (setq mail-followup-to (std11-field-body "Mail-Followup-To"))
528 (setq content-type (std11-field-body "Content-Type"))
529 (setq content-transfer-encoding (std11-field-body "Content-Transfer-Encoding"))
530 (goto-char (point-min))
531 (or (re-search-forward "\n\n" nil t)
532 (search-forward (concat mail-header-separator "\n") nil t))
535 (wl-draft to subject in-reply-to cc references newsgroups
537 content-type content-transfer-encoding
538 (buffer-substring (point) (point-max))
540 (if (member (nth 1 (std11-extract-address-components from))
541 wl-user-mail-address-list)
543 (and to (mail-position-on-field "To"))
544 (delete-other-windows)
545 (kill-buffer tmp-buf)))
546 (setq buffer-read-only nil) ;;??
547 (run-hooks 'wl-draft-reedit-hook))
549 (defun wl-draft-insert-current-message (dummy)
551 (let ((mail-reply-buffer (wl-message-get-original-buffer))
552 mail-citation-hook mail-yank-hooks
553 wl-draft-add-references wl-draft-cite-func)
555 (with-current-buffer mail-reply-buffer
557 (error "No current message")
558 (wl-draft-yank-from-mail-reply-buffer nil
559 wl-ignored-forwarded-headers))))
561 (defun wl-draft-insert-get-message (dummy)
562 (let ((fld (completing-read
564 (if (memq 'read-folder wl-use-folder-petname)
565 (wl-folder-get-entity-with-petname)
566 wl-folder-entity-hashtb)
567 nil nil wl-default-spec
568 'wl-read-folder-hist))
569 (number (call-interactively
570 (function (lambda (num)
571 (interactive "nNumber: ")
573 (mail-reply-buffer (get-buffer-create "*wl-draft-insert-get-message*"))
574 mail-citation-hook mail-yank-hooks
579 (elmo-read-msg-with-cache fld number mail-reply-buffer nil))
580 (wl-draft-yank-from-mail-reply-buffer nil))
581 (kill-buffer mail-reply-buffer))))
584 ;; default body citation func
586 (defun wl-default-draft-cite ()
587 (let ((mail-yank-ignored-headers "[^:]+:")
588 (mail-yank-prefix "> ")
589 (summary-buf wl-current-summary-buffer)
590 (message-buf (get-buffer (wl-current-message-buffer)))
591 from date cite-title num entity)
593 (buffer-live-p summary-buf)
595 (buffer-live-p message-buf))
598 (set-buffer summary-buf)
601 (set-buffer message-buf)
602 wl-message-buffer-cur-number))
603 (setq entity (assoc (cdr (assq num
604 (elmo-msgdb-get-number-alist
605 wl-summary-buffer-msgdb)))
606 (elmo-msgdb-get-overview
607 wl-summary-buffer-msgdb)))
608 (setq from (elmo-msgdb-overview-entity-get-from entity))
609 (setq date (elmo-msgdb-overview-entity-get-date entity)))
610 (setq cite-title (format "At %s,\n%s wrote:"
611 (or date "some time ago")
612 (wl-summary-from-func-internal
615 (insert cite-title "\n"))
616 (mail-indent-citation)))
618 (defvar wl-draft-buffer nil "Draft buffer to yank content")
619 (defun wl-draft-yank-to-draft-buffer (buffer)
620 "Yank BUFFER content to `wl-draft-buffer'."
621 (set-buffer wl-draft-buffer)
622 (let ((mail-reply-buffer buffer))
623 (wl-draft-yank-from-mail-reply-buffer nil)
624 (kill-buffer buffer)))
626 (defun wl-draft-yank-original (&optional arg)
627 "Yank original message."
630 (let (buf mail-reply-buffer)
633 (setq buf (current-buffer)))
634 (setq mail-reply-buffer buf)
635 (wl-draft-yank-from-mail-reply-buffer nil))
636 (wl-draft-yank-current-message-entity)))
638 (defun wl-draft-hide (editing-buffer)
639 "Hide the editing draft buffer if possible."
641 (when (and editing-buffer
642 (buffer-live-p editing-buffer))
643 (set-buffer editing-buffer)
644 (let ((sum-buf wl-draft-buffer-cur-summary-buffer)
645 fld-buf sum-win fld-win)
646 (if (and wl-draft-use-frame
647 (> (length (visible-frame-list)) 1))
653 ;; stay folder window if required
654 (when wl-stay-folder-window
655 (if (setq fld-buf (get-buffer wl-folder-buffer-name))
656 (if (setq fld-win (get-buffer-window fld-buf))
657 (select-window fld-win)
658 (if wl-draft-resume-folder-window ;; resume folder window
659 (switch-to-buffer fld-buf)))))
660 (if (buffer-live-p sum-buf)
661 (if (setq sum-win (get-buffer-window sum-buf t))
662 ;; if Summary is on the frame, select it.
663 (select-window sum-win)
664 ;; if summary is not on the frame, switch to it.
665 (if (and wl-stay-folder-window
666 (or wl-draft-resume-folder-window fld-win))
667 (wl-folder-select-buffer sum-buf)
668 (switch-to-buffer sum-buf)))))))
670 (defun wl-draft-delete (editing-buffer)
671 "kill the editing draft buffer and delete the file corresponds to it."
674 (set-buffer editing-buffer)
675 (if wl-draft-buffer-file-name
677 (if (file-exists-p wl-draft-buffer-file-name)
678 (delete-file wl-draft-buffer-file-name))
679 (let ((msg (and wl-draft-buffer-file-name
680 (string-match "[0-9]+$" wl-draft-buffer-file-name)
682 (match-string 0 wl-draft-buffer-file-name)))))
683 (wl-draft-config-info-operation msg 'delete))))
684 (set-buffer-modified-p nil) ; force kill
685 (kill-buffer editing-buffer))))
687 (defun wl-draft-kill (&optional force-kill)
688 "Kill current draft buffer and quit editing."
691 (when (and (or (eq major-mode 'wl-draft-mode)
692 (eq major-mode 'mail-mode))
694 (y-or-n-p "Kill Current Draft?")))
695 (let ((cur-buf (current-buffer)))
696 (wl-draft-hide cur-buf)
697 (wl-draft-delete cur-buf)))
700 (defun wl-draft-fcc ()
701 "Add a new Fcc field, with file name completion."
703 (or (mail-position-on-field "fcc" t) ;Put new field after exiting Fcc.
704 (mail-position-on-field "to"))
707 ;; function for wl-sent-message-via
709 (defmacro wl-draft-sent-message-p (type)
710 (` (eq (nth 1 (assq (, type) wl-sent-message-via)) 'sent)))
712 (defmacro wl-draft-set-sent-message (type result &optional server-port)
713 (` (let ((element (assq (, type) wl-sent-message-via)))
715 (unless (eq (nth 1 element) (, result))
716 (setcdr element (list (, result) (, server-port)))
717 (setq wl-sent-message-modified t))
718 (push (list (, type) (, result) (, server-port)) wl-sent-message-via)
719 (setq wl-sent-message-modified t)))))
721 (defun wl-draft-sent-message-results ()
722 (let ((results wl-sent-message-via)
723 unplugged-via sent-via)
725 (cond ((eq (nth 1 (car results)) 'unplugged)
726 (push (caar results) unplugged-via))
727 ((eq (nth 1 (car results)) 'sent)
728 (push (caar results) sent-via)))
729 (setq results (cdr results)))
730 (list unplugged-via sent-via)))
732 (defun wl-draft-write-sendlog (status proto server to id)
733 "Write send log file, if `wl-draft-sendlog' is non-nil."
734 (when wl-draft-sendlog
736 (let* ((tmp-buf (get-buffer-create " *wl-draft-sendlog*"))
737 (filename (expand-file-name wl-draft-sendlog-filename
739 (filesize (nth 7 (file-attributes filename)))
740 (server (if server (concat " server=" server) ""))
742 ((memq proto '(fcc queue))
743 (format " folder=\"%s\"" to))
745 (format " ng=<%s>" to))
750 (mapcar '(lambda(x) (format "<%s>" x)) to)
753 (id (if id (concat " id=" id) ""))
754 (time (wl-sendlog-time)))
757 (insert (format "%s proto=%s stat=%s%s%s%s\n"
758 time proto status server to id))
759 (if (and wl-draft-sendlog-max-size filesize
760 (> filesize wl-draft-sendlog-max-size))
761 (rename-file filename (concat filename ".old") t))
762 (if (file-writable-p filename)
763 (write-region (point-min) (point-max)
765 (message (format "%s is not writable." filename)))
766 (kill-buffer tmp-buf)))))
768 (defun wl-draft-get-header-delimiter (&optional delete)
769 ;; If DELETE is non-nil, replace the header delimiter with a blank line
771 (goto-char (point-min))
772 (when (re-search-forward
773 (concat "^" (regexp-quote mail-header-separator) "$\\|^$") nil t)
777 (setq delimline (point-marker)))
780 (defun wl-draft-send-mail-with-qmail ()
781 "Pass the prepared message buffer to qmail-inject.
782 Refer to the documentation for the variable `send-mail-function'
783 to find out how to use this."
784 (if (and wl-draft-qmail-send-plugged
785 (not (elmo-plugged-p)))
786 (wl-draft-set-sent-message 'mail 'unplugged)
788 (let ((id (std11-field-body "Message-ID"))
789 (to (std11-field-body "To")))
793 'call-process-region 1 (point-max) wl-qmail-inject-program
795 wl-qmail-inject-args))
796 ;; qmail-inject doesn't say anything on it's stdout/stderr,
797 ;; we have to look at the retval instead
799 (wl-draft-set-sent-message 'mail 'sent)
800 (wl-draft-write-sendlog 'ok 'qmail nil (list to) id)))
801 (1 (error "qmail-inject reported permanent failure"))
802 (111 (error "qmail-inject reported transient failure"))
803 ;; should never happen
804 (t (error "qmail-inject reported unknown failure"))))))
806 (defun wl-draft-parse-msg-id-list-string (string)
807 "Get msg-id list from STRING."
809 (dolist (parsed-id (std11-parse-msg-ids-string string))
810 (when (eq (car parsed-id) 'msg-id)
811 (setq msg-id-list (cons (std11-msg-id-string parsed-id)
813 (nreverse msg-id-list)))
815 (defun wl-draft-parse-mailbox-list (field &optional remove-group-list)
816 "Get mailbox list of FIELD from current buffer.
817 The buffer is expected to be narrowed to just the headers of the message.
818 If optional argument REMOVE-GROUP-LIST is non-nil, remove group list content
819 from current buffer."
821 (let ((case-fold-search t)
822 (inhibit-read-only t)
824 mailbox-list beg seq has-group-list)
825 (goto-char (point-min))
826 (while (re-search-forward (concat "^" (regexp-quote field) "[\t ]*:")
829 (re-search-forward "^[^ \t]" nil 'move)
831 (skip-chars-backward "\n")
832 (setq seq (std11-lexical-analyze
833 (buffer-substring-no-properties beg (point))))
834 (setq addresses (std11-parse-addresses seq))
836 (cond ((eq (car (car addresses)) 'group)
837 (setq has-group-list t)
841 'std11-address-string
842 (nth 2 (car addresses))))))
843 ((eq (car (car addresses)) 'mailbox)
844 (setq address (nth 1 (car addresses)))
848 (std11-addr-to-string
849 (if (eq (car address) 'phrase-route-addr)
852 (setq addresses (cdr addresses)))
853 (when (and remove-group-list has-group-list)
854 (delete-region beg (point))
855 (insert (wl-address-string-without-group-list-contents seq))))
858 (defun wl-draft-deduce-address-list (buffer header-start header-end)
859 "Get address list suitable for smtp RCPT TO:<address>.
860 Group list content is removed if `wl-draft-remove-group-list-contents' is
862 (let ((fields '("to" "cc" "bcc"))
863 (resent-fields '("resent-to" "resent-cc" "resent-bcc"))
868 (narrow-to-region header-start header-end)
869 (goto-char (point-min))
871 (if (re-search-forward "^resent-to[\t ]*:" nil t)
872 (setq fields resent-fields)))
876 (wl-draft-parse-mailbox-list
878 wl-draft-remove-group-list-contents)))
879 (setq fields (cdr fields)))
885 (defun wl-draft-send-mail-with-smtp ()
886 "Send the prepared message buffer with SMTP."
888 (let* ((errbuf (if mail-interactive
889 (generate-new-buffer " smtp errors")
892 (default-case-fold-search t)
893 (sender (or wl-envelope-from
894 (wl-address-header-extract-address wl-from)))
895 (delimline (save-excursion
896 (goto-char (point-min))
898 (concat "^" (regexp-quote mail-header-separator)
902 (or wl-smtp-posting-server
903 ;; Compatibility stuff for FLIM 1.12.5 or earlier.
904 ;; They don't accept a function as the value of `smtp-server'.
905 (if (functionp smtp-server)
910 (let (wl-draft-remove-group-list-contents)
911 (wl-draft-deduce-address-list
912 (current-buffer) (point-min) delimline)))
913 (or smtp-server "localhost"))))
914 (smtp-service (or wl-smtp-posting-port smtp-service))
915 (smtp-local-domain (or smtp-local-domain wl-local-domain))
916 (id (std11-field-body "message-id"))
918 (if (not (elmo-plugged-p smtp-server smtp-service))
919 (wl-draft-set-sent-message 'mail 'unplugged
920 (cons smtp-server smtp-service))
923 ;; Instead of `smtp-deduce-address-list'.
924 (setq recipients (wl-draft-deduce-address-list
925 (current-buffer) (point-min) delimline))
926 (unless recipients (error "No recipients"))
927 ;; Insert an extra newline if we need it to work around
928 ;; Sun's bug that swallows newlines.
929 (goto-char (1+ delimline))
930 (if (eval mail-mailer-swallows-blank-line)
932 ;;; (run-hooks 'wl-mail-send-pre-hook)
937 (wl-draft-delete-field "bcc" delimline)
938 (wl-draft-delete-field "resent-bcc" delimline)
939 (let (process-connection-type)
942 (wl-smtp-extension-bind
944 (smtp-send-buffer sender recipients (current-buffer))
946 (wl-draft-write-sendlog 'failed 'smtp smtp-server
948 (signal (car err) (cdr err)))))
949 (wl-draft-set-sent-message 'mail 'sent)
950 (wl-draft-write-sendlog
951 'ok 'smtp smtp-server recipients id)))))
953 (kill-buffer errbuf))))))
955 (defun wl-draft-send-mail-with-pop-before-smtp ()
956 "Send the prepared message buffer with POP-before-SMTP."
959 (let ((session (elmo-pop3-get-session
961 (or wl-pop-before-smtp-user
962 elmo-default-pop3-user)
963 (or wl-pop-before-smtp-authenticate-type
964 elmo-default-pop3-authenticate-type)
965 (or wl-pop-before-smtp-server
966 elmo-default-pop3-server)
967 (or wl-pop-before-smtp-port
968 elmo-default-pop3-port)
969 (or wl-pop-before-smtp-stream-type
970 elmo-default-pop3-stream-type)))))
971 (when session (elmo-network-close-session session)))
973 (wl-draft-send-mail-with-smtp))
975 (defun wl-draft-insert-required-fields (&optional force-msgid)
976 "Insert Message-ID, Date, and From field.
977 If FORCE-MSGID, ignore 'wl-insert-message-id'."
978 ;; Insert Message-Id field...
979 (goto-char (point-min))
980 (when (and (or force-msgid
981 wl-insert-message-id)
982 (not (re-search-forward "^Message-ID[ \t]*:" nil t)))
983 (insert (concat "Message-ID: "
984 (wl-draft-make-message-id-string)
986 ;; Insert date field.
987 (goto-char (point-min))
988 (or (re-search-forward "^Date[ \t]*:" nil t)
989 (wl-draft-insert-date-field))
990 ;; Insert from field.
991 (goto-char (point-min))
992 (or (re-search-forward "^From[ \t]*:" nil t)
993 (wl-draft-insert-from-field)))
995 (defun wl-draft-normal-send-func (editing-buffer kill-when-done)
996 "Send the message in the current buffer."
998 (std11-narrow-to-header mail-header-separator)
999 (wl-draft-insert-required-fields)
1000 ;; Delete null fields.
1001 (goto-char (point-min))
1002 (while (re-search-forward "^[^ \t\n:]+:[ \t]*\n" nil t)
1004 ;; ignore any blank lines in the header
1005 (while (re-search-forward "\n\n\n*" nil t)
1006 (replace-match "\n")))
1007 (run-hooks 'wl-mail-send-pre-hook) ;; X-PGP-Sig, Cancel-Lock
1008 (wl-draft-dispatch-message)
1009 (when kill-when-done
1010 ;; hide editing-buffer.
1011 (wl-draft-hide editing-buffer)
1012 ;; delete editing-buffer and its file.
1013 (wl-draft-delete editing-buffer)))
1015 (defun wl-draft-dispatch-message (&optional mes-string)
1016 "Send the message in the current buffer. Not modified the header fields."
1018 (if (and wl-draft-verbose-send mes-string)
1019 (message mes-string))
1021 (setq delimline (wl-draft-get-header-delimiter t))
1022 (unless wl-draft-fcc-list
1023 (setq wl-draft-fcc-list (wl-draft-get-fcc-list delimline)))
1025 (setq wl-sent-message-modified nil)
1028 (if (and (wl-message-mail-p)
1029 (not (wl-draft-sent-message-p 'mail)))
1030 (funcall wl-draft-send-mail-func))
1031 (if (and (wl-message-news-p)
1032 (not (wl-draft-sent-message-p 'news))
1033 (not (wl-message-field-exists-p "Resent-to")))
1034 (funcall wl-draft-send-news-func)))
1036 (let* ((status (wl-draft-sent-message-results))
1037 (unplugged-via (car status))
1038 (sent-via (nth 1 status)))
1039 ;; If one sent, process fcc folder.
1040 (if (and sent-via wl-draft-fcc-list)
1042 (wl-draft-do-fcc (wl-draft-get-header-delimiter) wl-draft-fcc-list)
1043 (setq wl-draft-fcc-list nil)))
1044 (if wl-draft-use-cache
1045 (let ((id (std11-field-body "Message-ID"))
1046 (elmo-enable-disconnected-operation t))
1047 (elmo-cache-save id nil nil nil)))
1048 ;; If one unplugged, append queue.
1049 (when (and unplugged-via
1050 wl-sent-message-modified)
1051 (if wl-draft-enable-queuing
1052 (wl-draft-queue-append wl-sent-message-via)
1053 (error "Unplugged")))
1054 (when wl-draft-verbose-send
1055 (if (and unplugged-via sent-via);; combined message
1057 (setq wl-draft-verbose-msg
1058 (format "Sending%s and Queuing%s..."
1059 sent-via unplugged-via))
1060 (message (concat wl-draft-verbose-msg "done")))
1062 (message (concat mes-string
1063 (if sent-via "done" "failed")))))))))
1064 (not wl-sent-message-modified)) ;; return value
1066 (defun wl-draft-raw-send (&optional kill-when-done force-pre-hook mes-string)
1067 "Force send current buffer as raw message."
1070 (let (wl-interactive-send
1071 ;;; wl-draft-verbose-send
1072 (wl-mail-send-pre-hook (and force-pre-hook wl-mail-send-pre-hook))
1073 ;;; wl-news-send-pre-hook
1076 (wl-draft-send kill-when-done mes-string))))
1078 (defun wl-draft-clone-local-variables ()
1079 (let ((locals (buffer-local-variables))
1082 (when (and (consp (car locals))
1084 (string-match wl-draft-clone-local-variable-regexp
1085 (symbol-name (car (car locals)))))
1086 (wl-append result (list (car (car locals)))))
1087 (setq locals (cdr locals)))
1090 (defun wl-draft-send (&optional kill-when-done mes-string)
1091 "Send current draft message.
1092 If KILL-WHEN-DONE is non-nil, current draft buffer is killed"
1094 ;; Don't call this explicitly.
1095 ;; Added to 'wl-draft-send-hook (by teranisi)
1096 ;; (wl-draft-config-exec)
1097 (run-hooks 'wl-draft-send-hook)
1098 (when (or (not wl-interactive-send)
1099 (y-or-n-p "Do you really want to send current draft? "))
1100 (let ((send-mail-function 'wl-draft-raw-send)
1101 (editing-buffer (current-buffer))
1102 (sending-buffer (wl-draft-generate-clone-buffer
1103 " *wl-draft-sending-buffer*"
1104 (append wl-draft-config-variables
1105 (wl-draft-clone-local-variables))))
1106 (wl-draft-verbose-msg nil)
1109 (save-excursion (set-buffer sending-buffer)
1110 (if (and (not (wl-message-mail-p))
1111 (not (wl-message-news-p)))
1112 (error "No recipient is specified"))
1113 (expand-abbrev) ; for mail-abbrevs
1114 (run-hooks 'mail-send-hook) ; translate buffer
1115 (if wl-draft-verbose-send
1116 (message (or mes-string "Sending...")))
1117 (funcall wl-draft-send-func editing-buffer kill-when-done)
1118 ;; Now perform actions on successful sending.
1119 (while mail-send-actions
1121 (apply (car (car mail-send-actions))
1122 (cdr (car mail-send-actions)))
1124 (setq mail-send-actions (cdr mail-send-actions)))
1125 (if (or (eq major-mode 'wl-draft-mode)
1126 (eq major-mode 'mail-mode))
1127 (local-set-key "\C-c\C-s" 'wl-draft-send)) ; override
1128 (if wl-draft-verbose-send
1129 (message (concat (or wl-draft-verbose-msg
1130 mes-string "Sending...")
1132 ;; kill sending buffer, anyway.
1133 (and (buffer-live-p sending-buffer)
1134 (kill-buffer sending-buffer))))))
1136 (defun wl-draft-save ()
1137 "Save current draft."
1140 (wl-draft-config-info-operation
1141 (and (string-match "[0-9]+$" wl-draft-buffer-file-name)
1143 (match-string 0 wl-draft-buffer-file-name)))
1146 (defun wl-draft-mimic-kill-buffer ()
1147 "Kill the current (draft) buffer with query."
1149 (let ((bufname (read-buffer (format "Kill buffer: (default %s) "
1152 (if (or (not bufname)
1153 (string-equal bufname "")
1154 (string-equal bufname (buffer-name)))
1155 (wl-draft-save-and-exit)
1156 (kill-buffer bufname))))
1158 (defun wl-draft-save-and-exit ()
1159 "Save current draft and exit current draft mode."
1162 (let ((editing-buffer (current-buffer)))
1163 (wl-draft-hide editing-buffer)
1164 (kill-buffer editing-buffer)))
1166 (defun wl-draft-send-and-exit ()
1167 "Send current draft message and kill it."
1171 (defun wl-draft-send-from-toolbar ()
1173 (let ((wl-interactive-send t))
1174 (wl-draft-send-and-exit)))
1176 (defun wl-draft-delete-field (field &optional delimline)
1177 (wl-draft-delete-fields (regexp-quote field) delimline))
1179 (defun wl-draft-delete-fields (regexp &optional delimline)
1182 (if (search-forward "\n\n" nil t)
1183 (setq delimline (point))
1184 (setq delimline (point-max))))
1185 (narrow-to-region (point-min) delimline)
1186 (goto-char (point-min))
1187 (let ((regexp (concat "^" regexp ":"))
1188 (case-fold-search t)
1191 (if (looking-at regexp)
1197 (if (re-search-forward "^[^ \t]" nil t)
1198 (goto-char (match-beginning 0))
1201 (if (re-search-forward "^[^ \t]" nil t)
1202 (goto-char (match-beginning 0))
1205 (defun wl-draft-get-fcc-list (header-end)
1207 (case-fold-search t))
1208 (or (markerp header-end) (error "header-end must be a marker"))
1210 (goto-char (point-min))
1211 (while (re-search-forward "^Fcc:[ \t]*" header-end t)
1213 (cons (buffer-substring-no-properties
1217 (skip-chars-backward " \t")
1221 (wl-folder-confirm-existence (eword-decode-string (car fcc-list))))
1222 (delete-region (match-beginning 0)
1223 (progn (forward-line 1) (point)))))
1226 (defun wl-draft-do-fcc (header-end &optional fcc-list)
1227 (let ((send-mail-buffer (current-buffer))
1228 (tembuf (generate-new-buffer " fcc output"))
1229 (case-fold-search t)
1231 (or (markerp header-end) (error "header-end must be a marker"))
1234 (setq fcc-list (wl-draft-get-fcc-list header-end)))
1237 ;; insert just the headers to avoid moving the gap more than
1238 ;; necessary (the message body could be arbitrarily huge.)
1239 (insert-buffer-substring send-mail-buffer 1 header-end)
1240 (wl-draft-insert-required-fields t)
1241 (goto-char (point-max))
1242 (insert-buffer-substring send-mail-buffer header-end)
1243 (let ((id (std11-field-body "Message-ID"))
1244 (elmo-enable-disconnected-operation t)
1247 (unless (or cache-saved
1248 (elmo-folder-plugged-p (car fcc-list)))
1249 (elmo-cache-save id nil nil nil) ;; for disconnected operation
1250 (setq cache-saved t))
1251 (if (elmo-append-msg (eword-decode-string (car fcc-list))
1253 (point-min) (point-max))
1255 (wl-draft-write-sendlog 'ok 'fcc nil (car fcc-list) id)
1256 (wl-draft-write-sendlog 'failed 'fcc nil (car fcc-list) id))
1257 (setq fcc-list (cdr fcc-list)))))
1258 (kill-buffer tembuf)))
1260 (defun wl-draft-on-field-p ()
1263 (goto-char (point-min))
1264 (search-forward (concat "\n" mail-header-separator "\n") nil 0)
1271 (if (or (looking-at ".*,[ \t]?$")
1272 (looking-at "^[^ \t]+:[ \t]+.*:$")); group list name
1274 (let ((pos (point)))
1277 (if (looking-at "^[ \t]")
1279 (if (re-search-forward ":" pos t) nil t)))))))
1282 (defun wl-draft (&optional to subject in-reply-to cc references newsgroups
1284 content-type content-transfer-encoding
1285 body edit-again summary-buf from)
1286 "Write and send mail/news message with Wanderlust."
1288 (unless (featurep 'wl)
1292 (wl-plugged-init t))
1293 (wl-init 'wl-draft) ;; returns immediately if already initialized.
1295 (setq summary-buf (wl-summary-get-buffer wl-summary-buffer-folder-name)))
1296 (let ((draft-folder-spec (elmo-folder-get-spec wl-draft-folder))
1297 buf-name file-name num wl-demo change-major-mode-hook)
1298 (if (not (eq (car draft-folder-spec) 'localdir))
1299 (error "%s folder cannot be used for draft folder" wl-draft-folder))
1300 (setq num (elmo-max-of-list (or (elmo-list-folder wl-draft-folder) '(0))))
1301 (setq num (+ 1 num))
1302 ;; To get unused buffer name.
1303 (while (get-buffer (concat wl-draft-folder "/" (int-to-string num)))
1304 (setq num (+ 1 num)))
1305 (setq buf-name (find-file-noselect
1307 (elmo-get-msg-filename wl-draft-folder
1309 (if wl-draft-use-frame
1310 (switch-to-buffer-other-frame buf-name)
1311 (switch-to-buffer buf-name))
1312 (set-buffer buf-name)
1313 (if (not (string-match (regexp-quote wl-draft-folder)
1315 (rename-buffer (concat wl-draft-folder "/" (int-to-string num))))
1316 (if (or (eq wl-draft-reply-buffer-style 'full)
1317 (eq this-command 'wl-draft)
1318 (eq this-command 'wl-summary-write)
1319 (eq this-command 'wl-summary-write-current-folder))
1320 (delete-other-windows))
1323 (setq wl-sent-message-via nil)
1324 (if (stringp (or from wl-from))
1325 (insert "From: " (or from wl-from) "\n"))
1326 (and (or (interactive-p)
1327 (eq this-command 'wl-summary-write)
1329 (insert "To: " (or to "") "\n"))
1330 (and cc (insert "Cc: " (or cc "") "\n"))
1331 (insert "Subject: " (or subject "") "\n")
1332 (and newsgroups (insert "Newsgroups: " newsgroups "\n"))
1333 (and mail-followup-to (insert "Mail-Followup-To: " mail-followup-to "\n"))
1334 (and wl-insert-mail-reply-to
1335 (insert "Mail-Reply-To: "
1336 (wl-address-header-extract-address
1338 (and in-reply-to (insert "In-Reply-To: " in-reply-to "\n"))
1339 (and references (insert "References: " references "\n"))
1340 (insert (funcall wl-generate-mailer-string-func)
1342 (setq wl-draft-buffer-file-name file-name)
1343 (if mail-default-reply-to
1344 (insert "Reply-To: " mail-default-reply-to "\n"))
1345 (wl-draft-insert-ccs "Bcc: " (or wl-bcc
1346 (and mail-self-blind (user-login-name))))
1347 (wl-draft-insert-ccs "Fcc: " wl-fcc)
1349 (insert "Organization: " wl-organization "\n"))
1350 (and wl-auto-insert-x-face
1351 (file-exists-p wl-x-face-file)
1352 (wl-draft-insert-x-face-field-here))
1353 (if mail-default-headers
1354 (insert mail-default-headers))
1355 (if (not (= (preceding-char) ?\n))
1359 (setq start (point))
1361 (insert "Content-type: " content-type "\n"))
1362 (when content-transfer-encoding
1363 (insert "Content-Transfer-Encoding: " content-transfer-encoding "\n"))
1364 (if (or content-type content-transfer-encoding)
1366 (and body (insert body))
1368 (narrow-to-region start (point))
1370 (wl-draft-decode-message-in-buffer))
1373 (put-text-property (point)
1375 (insert mail-header-separator "\n")
1377 'category 'mail-header-separator)))
1378 (put-text-property (point)
1380 (insert mail-header-separator "\n")
1382 'category 'mail-header-separator)
1383 (and body (insert body)))
1384 (as-binary-output-file
1385 (write-region (point-min)(point-max) wl-draft-buffer-file-name
1387 (wl-draft-editor-mode)
1388 (wl-draft-overload-functions)
1389 (wl-highlight-headers 'for-draft)
1390 (goto-char (point-min))
1391 (setq wl-draft-config-exec-flag t)
1393 (run-hooks 'wl-mail-setup-hook))
1394 (wl-user-agent-compose-internal) ;; user-agent
1395 (cond ((eq this-command 'wl-summary-write-current-newsgroup)
1396 (mail-position-on-field "Subject"))
1397 ((and (interactive-p) (null to))
1398 (mail-position-on-field "To"))
1400 (goto-char (point-max))))
1401 (setq wl-draft-buffer-cur-summary-buffer (or summary-buf
1403 wl-summary-buffer-name)))
1406 (defsubst wl-draft-insert-ccs (str cc)
1412 (null (and wl-draft-delete-myself-from-bcc-fcc
1414 (mapcar 'wl-address-header-extract-address
1416 (wl-parse-addresses (std11-field-body "To"))
1417 (wl-parse-addresses (std11-field-body "Cc"))))
1418 (mapcar 'downcase wl-subscribed-mailing-list)))))
1419 (insert str field "\n"))))
1421 (defun wl-draft-elmo-nntp-send ()
1422 (let ((elmo-nntp-post-pre-hook wl-news-send-pre-hook)
1423 (elmo-default-nntp-user
1424 (or wl-nntp-posting-user elmo-default-nntp-user))
1425 (elmo-default-nntp-server
1426 (or wl-nntp-posting-server elmo-default-nntp-server))
1427 (elmo-default-nntp-port
1428 (or wl-nntp-posting-port elmo-default-nntp-port))
1429 (elmo-default-nntp-stream-type
1430 (or wl-nntp-posting-stream-type elmo-default-nntp-stream-type)))
1431 (if (not (elmo-plugged-p elmo-default-nntp-server elmo-default-nntp-port))
1432 (wl-draft-set-sent-message 'news 'unplugged
1433 (cons elmo-default-nntp-server
1434 elmo-default-nntp-port))
1435 (elmo-nntp-post elmo-default-nntp-server (current-buffer))
1436 (wl-draft-set-sent-message 'news 'sent)
1437 (wl-draft-write-sendlog 'ok 'nntp elmo-default-nntp-server
1438 (std11-field-body "Newsgroups")
1439 (std11-field-body "Message-ID")))))
1441 (defun wl-draft-generate-clone-buffer (name &optional local-variables)
1442 "generate clone of current buffer named NAME."
1443 (let ((editing-buffer (current-buffer)))
1445 (set-buffer (generate-new-buffer name))
1448 (wl-draft-editor-mode)
1449 (insert-buffer editing-buffer)
1451 (while local-variables
1452 (make-local-variable (car local-variables))
1453 (set (car local-variables)
1455 (set-buffer editing-buffer)
1456 (symbol-value (car local-variables))))
1457 (setq local-variables (cdr local-variables)))
1460 (defun wl-draft-reedit (number)
1461 (let ((draft-folder-spec (elmo-folder-get-spec wl-draft-folder))
1463 buf-name file-name change-major-mode-hook)
1464 (setq file-name (expand-file-name
1465 (int-to-string number)
1467 (nth 1 draft-folder-spec)
1468 elmo-localdir-folder-path)))
1469 (unless (file-exists-p file-name)
1470 (error "File %s does not exist" file-name))
1471 (setq buf-name (find-file-noselect file-name))
1472 (if wl-draft-use-frame
1473 (switch-to-buffer-other-frame buf-name)
1474 (switch-to-buffer buf-name))
1475 (set-buffer buf-name)
1476 (if (not (string-match (regexp-quote wl-draft-folder)
1478 (rename-buffer (concat wl-draft-folder "/" (buffer-name))))
1481 (setq wl-sent-message-via nil)
1482 (setq wl-draft-buffer-file-name file-name)
1483 (wl-draft-config-info-operation number 'load)
1484 (goto-char (point-min))
1485 (or (re-search-forward "\n\n" nil t)
1486 (search-forward (concat mail-header-separator "\n") nil t))
1487 (write-region (point-min)(point-max) wl-draft-buffer-file-name
1489 (wl-draft-overload-functions)
1490 (wl-draft-editor-mode)
1491 (wl-highlight-headers 'for-draft)
1492 (run-hooks 'wl-draft-reedit-hook)
1493 (goto-char (point-max))
1497 (defmacro wl-draft-body-goto-top ()
1499 (goto-char (point-min))
1500 (if (re-search-forward mail-header-separator nil t)
1502 (goto-char (point-max))))))
1504 (defmacro wl-draft-body-goto-bottom ()
1505 (` (goto-char (point-max))))
1507 (defmacro wl-draft-config-body-goto-header ()
1509 (goto-char (point-min))
1510 (if (re-search-forward mail-header-separator nil t)
1512 (goto-char (point-max))))))
1514 (defun wl-draft-config-sub-body (content)
1515 (wl-draft-body-goto-top)
1516 (delete-region (point) (point-max))
1517 (if content (insert (eval content))))
1519 (defun wl-draft-config-sub-top (content)
1520 (wl-draft-body-goto-top)
1521 (if content (insert (eval content))))
1523 (defun wl-draft-config-sub-bottom (content)
1524 (wl-draft-body-goto-bottom)
1525 (if content (insert (eval content))))
1527 (defun wl-draft-config-sub-header (content)
1528 (wl-draft-config-body-goto-header)
1529 (if content (insert (concat (eval content) "\n"))))
1531 (defsubst wl-draft-config-sub-file (content)
1532 (let ((coding-system-for-read wl-cs-autoconv)
1533 (file (expand-file-name (eval content))))
1534 (if (file-exists-p file)
1535 (insert-file-contents file)
1536 (error "%s: no exists file" file))))
1538 (defun wl-draft-config-sub-body-file (content)
1539 (wl-draft-body-goto-top)
1540 (delete-region (point) (point-max))
1541 (wl-draft-config-sub-file content))
1543 (defun wl-draft-config-sub-top-file (content)
1544 (wl-draft-body-goto-top)
1545 (wl-draft-config-sub-file content))
1547 (defun wl-draft-config-sub-bottom-file (content)
1548 (wl-draft-body-goto-bottom)
1549 (wl-draft-config-sub-file content))
1551 (defun wl-draft-config-sub-header-file (content)
1552 (wl-draft-config-body-goto-header)
1553 (wl-draft-config-sub-file content))
1555 (defun wl-draft-config-sub-template (content)
1556 (setq wl-draft-config-variables
1557 (wl-template-insert (eval content))))
1559 (defun wl-draft-config-sub-x-face (content)
1560 (if (and (string-match "\\.xbm\\(\\.gz\\)?$" content)
1561 (fboundp 'x-face-insert)) ; x-face.el is installed.
1562 (x-face-insert content)
1563 (wl-draft-replace-field "X-Face" (elmo-get-file-string content t) t)))
1565 (defsubst wl-draft-config-sub-func (field content)
1567 (if (setq func (assq field wl-draft-config-sub-func-alist))
1568 (let (wl-draft-config-variables)
1569 (funcall (cdr func) content)
1570 ;; for wl-draft-config-sub-template
1571 (cons t wl-draft-config-variables)))))
1573 (defsubst wl-draft-config-exec-sub (clist)
1574 (let (config local-variables)
1576 (setq config (car clist))
1579 (let ((field (car config))
1580 (content (cdr config))
1584 (wl-draft-replace-field field (eval content) t))
1585 ((setq ret-val (wl-draft-config-sub-func field content))
1586 (if (cdr ret-val) ;; for wl-draft-config-sub-template
1587 (wl-append local-variables (cdr ret-val))))
1588 ((boundp field) ;; variable
1589 (make-local-variable field)
1590 (set field (eval content))
1591 (wl-append local-variables (list field)))
1593 (error "%s: not variable" field)))))
1594 ((or (functionp config)
1595 (and (symbolp config)
1599 (error "%s: not supported type" config)))
1600 (setq clist (cdr clist)))
1603 (defun wl-draft-prepared-config-exec (&optional config-alist reply-buf)
1604 "Change headers in draft preparation time."
1606 (unless wl-draft-reedit
1609 (and (boundp 'wl-draft-prepared-config-alist)
1610 wl-draft-prepared-config-alist) ;; For compatible.
1611 wl-draft-config-alist)))
1613 (wl-draft-config-exec config-alist reply-buf)))))
1615 (defun wl-draft-config-exec (&optional config-alist reply-buf)
1616 "Change headers in draft sending time."
1618 (let ((case-fold-search t)
1619 (alist (or config-alist wl-draft-config-alist))
1620 (reply-buf (or reply-buf (and (buffer-live-p wl-draft-reply-buffer)
1621 wl-draft-reply-buffer)))
1622 (local-variables wl-draft-config-variables)
1624 (when (and (or (interactive-p)
1625 wl-draft-config-exec-flag)
1630 (setq key (caar alist)
1637 (set-buffer reply-buf)
1639 (std11-narrow-to-header)
1640 (goto-char (point-min))
1641 (re-search-forward (car clist) nil t))))
1642 (wl-draft-config-exec-sub (cdr clist))
1645 (when (save-restriction
1646 (std11-narrow-to-header mail-header-separator)
1647 (goto-char (point-min))
1648 (re-search-forward key nil t))
1649 (wl-append local-variables
1650 (wl-draft-config-exec-sub clist))
1653 (wl-append local-variables
1654 (wl-draft-config-exec-sub clist))
1656 (if (and found wl-draft-config-matchone)
1658 (setq alist (cdr alist))))
1660 (setq wl-draft-config-exec-flag nil))
1661 (run-hooks 'wl-draft-config-exec-hook)
1662 (put-text-property (point-min)(point-max) 'face nil)
1663 (wl-highlight-message (point-min)(point-max) t)
1664 (setq wl-draft-config-variables
1665 (elmo-uniq-list local-variables))))))
1667 (defun wl-draft-replace-field (field content &optional add)
1670 (let ((case-fold-search t)
1671 (inhibit-read-only t) ;; added by teranisi.
1673 (std11-narrow-to-header mail-header-separator)
1674 (goto-char (point-min))
1675 (if (re-search-forward (concat "^" (regexp-quote field) ":") nil t)
1680 (re-search-forward "^[^ \t]" nil 'move)
1682 (skip-chars-backward "\n")
1683 (delete-region beg (point))
1684 (insert " " content))
1689 (re-search-forward "^[^ \t]" nil 'move)
1691 (delete-region beg (point)))
1692 (when (and add content)
1694 (goto-char (point-max))
1695 (insert (concat field ": " content "\n"))))))))
1697 (defun wl-draft-config-info-operation (msg operation)
1698 (let* ((msgdb-dir (elmo-msgdb-expand-path wl-draft-folder))
1701 (format "%s-%d" wl-draft-config-save-filename msg)
1703 element alist variable)
1705 ((eq operation 'save)
1706 (let ((variables (elmo-uniq-list wl-draft-config-variables)))
1707 (while (setq variable (pop variables))
1708 (when (boundp variable)
1710 (list (cons variable (eval variable))))))
1711 (elmo-object-save filename alist)))
1712 ((eq operation 'load)
1713 (setq alist (elmo-object-load filename))
1714 (while (setq element (pop alist))
1715 (set (make-local-variable (car element)) (cdr element))
1716 (wl-append wl-draft-config-variables (list (car element)))))
1717 ((eq operation 'delete)
1718 (if (file-exists-p filename)
1719 (delete-file filename))))))
1721 (defun wl-draft-queue-info-operation (msg operation
1722 &optional add-sent-message-via)
1723 (let* ((msgdb-dir (elmo-msgdb-expand-path wl-queue-folder))
1726 (format "%s-%d" wl-draft-queue-save-filename msg)
1728 element alist variable)
1730 ((eq operation 'save)
1731 (let ((variables (elmo-uniq-list
1732 (append wl-draft-queue-save-variables
1733 wl-draft-config-variables
1734 (list 'wl-draft-fcc-list)))))
1735 (if add-sent-message-via
1736 (push 'wl-sent-message-via variables))
1737 (while (setq variable (pop variables))
1738 (when (boundp variable)
1740 (list (cons variable (eval variable))))))
1741 (elmo-object-save filename alist)))
1742 ((eq operation 'load)
1743 (setq alist (elmo-object-load filename))
1744 (while (setq element (pop alist))
1745 (set (make-local-variable (car element)) (cdr element))))
1746 ((eq operation 'get-sent-via)
1747 (setq alist (elmo-object-load filename))
1748 (cdr (assq 'wl-sent-message-via alist)))
1749 ((eq operation 'delete)
1750 (if (file-exists-p filename)
1751 (delete-file filename))))))
1753 (defun wl-draft-queue-append (wl-sent-message-via)
1754 (if wl-draft-verbose-send
1755 (message "Queuing..."))
1756 (let ((send-buffer (current-buffer))
1757 (message-id (std11-field-body "Message-ID")))
1758 (if (elmo-append-msg wl-queue-folder
1759 (buffer-substring (point-min) (point-max))
1763 (elmo-dop-lock-message message-id))
1764 (wl-draft-queue-info-operation
1765 (car (elmo-max-of-folder wl-queue-folder))
1766 'save wl-sent-message-via)
1767 (wl-draft-write-sendlog 'ok 'queue nil wl-queue-folder message-id)
1768 (when wl-draft-verbose-send
1769 (setq wl-draft-verbose-msg "Queuing...")
1770 (message "Queuing...done")))
1771 (wl-draft-write-sendlog 'failed 'queue nil wl-queue-folder message-id)
1772 (error "Queuing failed"))))
1774 (defun wl-draft-queue-flush ()
1775 "Flush draft queue."
1777 (let ((msgs2 (elmo-list-folder wl-queue-folder))
1780 (wl-draft-queue-flushing t)
1781 msgs failure len buffer msgid sent-via)
1782 ;; get plugged send message
1784 (setq sent-via (wl-draft-queue-info-operation (car msgs2) 'get-sent-via))
1787 (when (and (eq (nth 1 (car sent-via)) 'unplugged)
1789 (car (nth 2 (car sent-via)))
1790 (cdr (nth 2 (car sent-via)))))
1791 (wl-append msgs (list (car msgs2)))
1793 (setq sent-via (cdr sent-via))))
1794 (setq msgs2 (cdr msgs2)))
1795 (when (> (setq len (length msgs)) 0)
1796 (if (elmo-y-or-n-p (format
1797 "%d message(s) are in the sending queue. Send now?"
1799 (not elmo-dop-flush-confirm) t)
1802 (setq buffer (get-buffer-create " *wl-draft-queue-flush*"))
1805 ;; reset buffer local variables
1806 (kill-all-local-variables)
1810 (setq wl-sent-message-via nil)
1811 (wl-draft-queue-info-operation (car msgs) 'load)
1812 (elmo-read-msg-no-cache wl-queue-folder (car msgs)
1815 (setq failure (funcall
1816 wl-draft-queue-flush-send-func
1817 (format "Sending (%d/%d)..." i len)))
1818 ;;; (wl-draft-raw-send nil nil
1819 ;;; (format "Sending (%d/%d)..." i len))
1821 (elmo-display-error err t)
1826 (elmo-delete-msgs wl-queue-folder (cons (car msgs) nil))
1827 (wl-draft-queue-info-operation (car msgs) 'delete)
1828 (elmo-dop-unlock-message (std11-field-body "Message-ID"))
1829 (setq performed (+ 1 performed)))
1830 (setq msgs (cdr msgs)))
1831 (kill-buffer buffer)
1832 (message "%d message(s) are sent." performed)))
1833 (message "%d message(s) are remained to be sent." len))
1836 (defun wl-jump-to-draft-buffer (&optional arg)
1837 "Jump to the draft if exists."
1840 (wl-jump-to-draft-folder)
1841 (let ((bufs (buffer-list))
1842 (draft-regexp (concat
1845 (nth 1 (elmo-folder-get-spec wl-draft-folder))
1847 elmo-localdir-folder-path)))))
1851 (setq buf (buffer-file-name (car bufs)))
1852 (string-match draft-regexp buf))
1853 (setq draft-bufs (cons (buffer-name (car bufs)) draft-bufs)))
1854 (setq bufs (cdr bufs)))
1857 (message "No draft buffer exist."))
1860 (sort draft-bufs (function (lambda (a b) (not (string< a b))))))
1861 (if (setq buf (cdr (member (buffer-name) draft-bufs)))
1862 (setq buf (car buf))
1863 (setq buf (car draft-bufs)))
1864 (switch-to-buffer buf))))))
1866 (defun wl-jump-to-draft-folder ()
1867 (let ((msgs (reverse (elmo-list-folder wl-draft-folder)))
1868 (mybuf (buffer-name))
1871 (message "No draft message exist.")
1872 (if (string-match (concat "^" wl-draft-folder "/") mybuf)
1873 (setq msg (cadr (memq
1874 (string-to-int (substring mybuf (match-end 0)))
1876 (or msg (setq msg (car msgs)))
1877 (if (setq buf (get-buffer (format "%s/%d" wl-draft-folder msg)))
1878 (switch-to-buffer buf)
1879 (wl-draft-reedit msg)))))
1881 (defun wl-draft-highlight-and-recenter (&optional n)
1883 (if wl-highlight-body-too
1884 (let ((beg (point-min))
1886 (put-text-property beg end 'face nil)
1887 (wl-highlight-message beg end t)))
1890 ;;;; user-agent support by Sen Nagata
1892 ;; this appears to be necessarily global...
1893 (defvar wl-user-agent-compose-p nil)
1894 (defvar wl-user-agent-headers-and-body-alist nil)
1896 ;; this should be a generic function for mail-mode -- i wish there was
1897 ;; something like it in sendmail.el
1898 (defun wl-user-agent-insert-header (header-name header-value)
1899 "Insert HEADER-NAME w/ value HEADER-VALUE into a message."
1900 ;; it seems like overriding existing headers is acceptable -- should
1901 ;; we provide an option?
1903 ;; plan was: unfold header (might be folded), remove existing value, insert
1905 ;; wl doesn't seem to fold header lines yet anyway :-)
1907 (let ((kill-whole-line t)
1909 (mail-position-on-field (capitalize header-name))
1910 (setq end-of-line (point))
1912 (re-search-forward ":" end-of-line)
1913 (insert (concat " " header-value "\n"))
1916 ;; this should be a generic function for mail-mode -- i wish there was
1917 ;; something like it in sendmail.el
1919 ;; ** haven't dealt w/ case where the body is already set **
1920 (defun wl-user-agent-insert-body (body-text)
1921 "Insert a body of text, BODY-TEXT, into a message."
1922 ;; code defensively... :-P
1923 (goto-char (point-min))
1924 (search-forward mail-header-separator)
1929 (defun wl-user-agent-compose (&optional to subject other-headers continue
1930 switch-function yank-action
1932 "Support the `compose-mail' interface for wl.
1933 Only support for TO, SUBJECT, and OTHER-HEADERS has been implemented.
1934 Support for CONTINUE, YANK-ACTION, and SEND-ACTIONS has not
1935 been implemented yet. Partial support for SWITCH-FUNCTION now supported."
1937 (unless (featurep 'wl)
1939 ;; protect these -- to and subject get bound at some point, so it looks
1940 ;; to be necessary to protect the values used w/in
1941 (let ((wl-user-agent-headers-and-body-alist other-headers)
1942 (wl-draft-use-frame (eq switch-function 'switch-to-buffer-other-frame))
1943 (wl-draft-reply-buffer-style 'split))
1944 (when (eq switch-function 'switch-to-buffer-other-window)
1945 (when (one-window-p t)
1946 (if (window-minibuffer-p) (other-window 1))
1950 (if (wl-string-match-assoc "to" wl-user-agent-headers-and-body-alist
1953 (wl-string-match-assoc "to" wl-user-agent-headers-and-body-alist
1956 (setq wl-user-agent-headers-and-body-alist
1957 (cons (cons "to" to)
1958 wl-user-agent-headers-and-body-alist))))
1960 (if (wl-string-match-assoc "subject"
1961 wl-user-agent-headers-and-body-alist
1964 (wl-string-match-assoc "subject"
1965 wl-user-agent-headers-and-body-alist
1968 (setq wl-user-agent-headers-and-body-alist
1969 (cons (cons "subject" subject)
1970 wl-user-agent-headers-and-body-alist))))
1971 ;; i think this is what we want to use...
1974 ;; tell the hook-function to do its stuff
1975 (setq wl-user-agent-compose-p t)
1976 ;; because to get the hooks working, wl-draft has to think it has
1977 ;; been called interactively
1978 (call-interactively 'wl-draft))
1979 (setq wl-user-agent-compose-p nil))))
1981 (defun wl-user-agent-compose-internal ()
1982 "Manipulate headers and/or a body of a draft message."
1983 ;; being called from wl-user-agent-compose?
1984 (if wl-user-agent-compose-p
1987 (let ((headers wl-user-agent-headers-and-body-alist)
1988 (case-fold-search t))
1991 (if (not (string-match "^body$" (car (car headers))))
1992 (wl-user-agent-insert-header
1993 (car (car headers)) (cdr (car headers)))
1995 (setq headers (cdr headers))))
1996 ;; highlight headers (from wl-draft in wl-draft.el)
1997 (wl-highlight-headers 'for-draft)
1999 (if (wl-string-match-assoc "body" wl-user-agent-headers-and-body-alist
2001 (wl-user-agent-insert-body
2002 (cdr (wl-string-match-assoc
2004 wl-user-agent-headers-and-body-alist 'ignore-case)))))
2008 (product-provide (provide 'wl-draft) (require 'wl-version))
2010 ;;; wl-draft.el ends here