wl/wl-draft.el

   1 ;;; wl-draft.el -- Message draft mode for Wanderlust.
   2
   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>
   5
   6 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
   7 ;;      Masahiro MURATA <muse@ba2.so-net.ne.jp>
   8 ;; Keywords: mail, net news
   9
  10 ;; This file is part of Wanderlust (Yet Another Message Interface on Emacsen).
  11
  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)
  15 ;; any later version.
  16 ;;
  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.
  21 ;;
  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.
  26 ;;
  27
  28 ;;; Commentary:
  29 ;;
  30
  31 ;;; Code:
  32 ;;
  33
  34 (require 'sendmail)
  35 (require 'wl-template)
  36 (require 'emu)
  37 (condition-case nil (require 'timezone) (error nil))
  38 (require 'std11)
  39 (require 'wl-vars)
  40
  41 (defvar x-face-add-x-face-version-header)
  42 (defvar mail-reply-buffer)
  43 (defvar mail-from-style)
  44 ;(defvar smtp-sasl-mechanisms)
  45 ;(defvar smtp-sasl-user-name)
  46 ;(defvar smtp-use-starttls)
  47
  48 (eval-when-compile
  49   (require 'elmo-pop3)
  50   (defalias-maybe 'x-face-insert 'ignore)
  51   (defalias-maybe 'x-face-insert-version-header 'ignore)
  52   (defalias-maybe 'wl-init 'ignore)
  53   (defalias-maybe 'wl-draft-mode 'ignore))
  54
  55 (defvar wl-draft-buf-name "Draft")
  56 (defvar wl-caesar-region-func nil)
  57 (defvar wl-draft-cite-func 'wl-default-draft-cite)
  58 (defvar wl-draft-buffer-file-name nil)
  59 (defvar wl-draft-field-completion-list nil)
  60 (defvar wl-draft-verbose-send t)
  61 (defvar wl-draft-verbose-msg nil)
  62 (defvar wl-draft-queue-flushing nil)
  63 (defvar wl-draft-config-variables nil)
  64 (defvar wl-draft-config-exec-flag t)
  65 (defvar wl-draft-buffer-cur-summary-buffer nil)
  66 (defvar wl-draft-clone-local-variable-regexp "^\\(wl\\|mime\\)")
  67 (defvar wl-draft-sendlog-filename "sendlog")
  68 (defvar wl-draft-queue-save-filename "qinfo")
  69 (defvar wl-draft-config-save-filename "config")
  70 (defvar wl-draft-queue-flush-send-func 'wl-draft-dispatch-message)
  71 (defvar wl-sent-message-via nil)
  72 (defvar wl-sent-message-modified nil)
  73 (defvar wl-draft-fcc-list nil)
  74 (defvar wl-draft-reedit nil)
  75 (defvar wl-draft-reply-buffer nil)
  76 (defvar wl-draft-forward nil)
  77
  78 (defvar wl-draft-config-sub-func-alist
  79   '((body        . wl-draft-config-sub-body)
  80     (top         . wl-draft-config-sub-top)
  81     (bottom      . wl-draft-config-sub-bottom)
  82     (header      . wl-draft-config-sub-header)
  83     (body-file   . wl-draft-config-sub-body-file)
  84     (top-file    . wl-draft-config-sub-top-file)
  85     (bottom-file . wl-draft-config-sub-bottom-file)
  86     (header-file . wl-draft-config-sub-header-file)
  87     (template    . wl-draft-config-sub-template)
  88     (x-face      . wl-draft-config-sub-x-face)))
  89
  90 (make-variable-buffer-local 'wl-draft-buffer-file-name)
  91 (make-variable-buffer-local 'wl-draft-buffer-cur-summary-buffer)
  92 (make-variable-buffer-local 'wl-draft-config-variables)
  93 (make-variable-buffer-local 'wl-draft-config-exec-flag)
  94 (make-variable-buffer-local 'wl-sent-message-via)
  95 (make-variable-buffer-local 'wl-draft-fcc-list)
  96 (make-variable-buffer-local 'wl-draft-reply-buffer)
  97
  98 ;;; SMTP binding by Daiki Ueno <ueno@ueda.info.waseda.ac.jp>
  99 ;;;(defvar wl-smtp-features
 100 ;;;  '(((smtp-authenticate-type
 101 ;;;      (if wl-smtp-authenticate-type
 102 ;;;       (intern (downcase (format "%s" wl-smtp-authenticate-type)))))
 103 ;;;     ((smtp-authenticate-user wl-smtp-posting-user)
 104 ;;;      ((smtp-authenticate-passphrase
 105 ;;;     (elmo-get-passwd
 106 ;;;      (format "%s@%s"
 107 ;;;              smtp-authenticate-user
 108 ;;;              smtp-server))))))
 109 ;;;    (smtp-connection-type))
 110 ;;;  "Additional SMTP features.")
 111
 112 ;;;(eval-when-compile
 113 ;;;  (defun wl-smtp-parse-extension (exts parents)
 114 ;;;    (let (bindings binding feature)
 115 ;;;      (dolist (ext exts)
 116 ;;;     (setq feature (if (listp (car ext)) (caar ext) (car ext))
 117 ;;;           binding
 118 ;;;           (` ((, feature)
 119 ;;;               (or (, (if (listp (car ext))
 120 ;;;                          (cadar ext)
 121 ;;;                        (let ((wl-feature
 122 ;;;                               (intern
 123 ;;;                                (concat "wl-" (symbol-name feature)))))
 124 ;;;                          (if (boundp wl-feature)
 125 ;;;                              wl-feature))))
 126 ;;;                   (and (boundp '(, feature)) (, feature))))))
 127 ;;;     (when parents
 128 ;;;       (setcdr binding (list (append '(and) parents (cdr binding)))))
 129 ;;;     (setq bindings
 130 ;;;           (nconc bindings (list binding)
 131 ;;;                  (wl-smtp-parse-extension
 132 ;;;                   (cdr ext) (cons feature parents)))))
 133 ;;;      bindings)))
 134
 135 ;;;(defmacro wl-smtp-extension-bind (&rest body)
 136 ;;;  "Return a `let' form that binds all variables of SMTP extension.
 137 ;;;After this is done, BODY will be executed in the scope
 138 ;;;of the `let' form.
 139 ;;;
 140 ;;;The variables bound and their default values are described by
 141 ;;;the `wl-smtp-features' variable."
 142 ;;;  (` (let* (, (wl-smtp-parse-extension wl-smtp-features nil))
 143 ;;;       (,@ body))))
 144
 145 (defmacro wl-smtp-extension-bind (&rest body)
 146   (` (let* ((smtp-sasl-mechanisms
 147              (if wl-smtp-authenticate-type
 148                  (mapcar 'upcase
 149                          (if (listp wl-smtp-authenticate-type)
 150                              wl-smtp-authenticate-type
 151                            (list wl-smtp-authenticate-type)))))
 152             (smtp-use-sasl (and smtp-sasl-mechanisms t))
 153             (smtp-use-starttls wl-smtp-connection-type)
 154             smtp-sasl-user-name smtp-sasl-properties sasl-read-passphrase)
 155        (if (and (string= (car smtp-sasl-mechanisms) "DIGEST-MD5")
 156                 ;; sendmail bug?
 157                 (string-match "^\\([^@]*\\)@\\([^@]*\\)"
 158                               wl-smtp-posting-user))
 159            (setq smtp-sasl-user-name (match-string 1 wl-smtp-posting-user)
 160                  smtp-sasl-properties (list 'realm
 161                                             (match-string 2 wl-smtp-posting-user)))
 162          (setq smtp-sasl-user-name wl-smtp-posting-user
 163                smtp-sasl-properties nil))
 164          (setq sasl-read-passphrase
 165              (function
 166               (lambda (prompt)
 167                 (elmo-get-passwd
 168                  (format "%s@%s"
 169                          smtp-sasl-user-name
 170                          smtp-server)))))
 171        (,@ body))))
 172
 173 (defun wl-draft-insert-date-field ()
 174   "Insert Date field."
 175   (insert "Date: " (wl-make-date-string) "\n"))
 176
 177 (defun wl-draft-insert-from-field ()
 178   "Insert From field."
 179   ;; Put the "From:" field in unless for some odd reason
 180   ;; they put one in themselves.
 181   (let* ((login (or user-mail-address (user-login-name)))
 182          (fullname (user-full-name)))
 183     (cond ((eq mail-from-style 'angles)
 184            (insert "From: " fullname)
 185            (let ((fullname-start (+ (point-min) 6))
 186                  (fullname-end (point-marker)))
 187              (goto-char fullname-start)
 188              ;; Look for a character that cannot appear unquoted
 189              ;; according to RFC 822.
 190              (if (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]"
 191                                     fullname-end 1)
 192                  (progn
 193                    ;; Quote fullname, escaping specials.
 194                    (goto-char fullname-start)
 195                    (insert "\"")
 196                    (while (re-search-forward "[\"\\]"
 197                                              fullname-end 1)
 198                      (replace-match "\\\\\\&" t))
 199                    (insert "\""))))
 200            (insert " <" login ">\n"))
 201           ((eq mail-from-style 'parens)
 202            (insert "From: " login " (")
 203            (let ((fullname-start (point)))
 204              (insert fullname)
 205              (let ((fullname-end (point-marker)))
 206                (goto-char fullname-start)
 207                ;; RFC 822 says \ and nonmatching parentheses
 208                ;; must be escaped in comments.
 209                ;; Escape every instance of ()\ ...
 210                (while (re-search-forward "[()\\]" fullname-end 1)
 211                  (replace-match "\\\\\\&" t))
 212                ;; ... then undo escaping of matching parentheses,
 213                ;; including matching nested parentheses.
 214                (goto-char fullname-start)
 215                (while (re-search-forward
 216                        "\\(\\=\\|[^\\]\\(\\\\\\\\\\)*\\)\\\\(\\(\\([^\\]\\|\\\\\\\\\\)*\\)\\\\)"
 217                        fullname-end 1)
 218                  (replace-match "\\1(\\3)" t)
 219                  (goto-char fullname-start))))
 220            (insert ")\n"))
 221           ((null mail-from-style)
 222            (insert "From: " login "\n")))))
 223
 224 (defun wl-draft-insert-x-face-field ()
 225   "Insert x-face header."
 226   (interactive)
 227   (if (not (file-exists-p wl-x-face-file))
 228       (error "File %s does not exist" wl-x-face-file)
 229     (beginning-of-buffer)
 230     (search-forward mail-header-separator nil t)
 231     (beginning-of-line)
 232     (wl-draft-insert-x-face-field-here)
 233     (run-hooks 'wl-draft-insert-x-face-field-hook) ; highlight it if you want.
 234     ))
 235
 236 (defun wl-draft-insert-x-face-field-here ()
 237   "Insert x-face field at point."
 238   (let ((x-face-string (elmo-get-file-string wl-x-face-file)))
 239     (if (string-match "^[ \t]*" x-face-string)
 240         (setq x-face-string (substring x-face-string (match-end 0))))
 241     (insert "X-Face: " x-face-string))
 242   (if (not (= (preceding-char) ?\n))
 243       (insert ?\n))
 244   (and (fboundp 'x-face-insert-version-header) ; x-face.el...
 245        (boundp 'x-face-add-x-face-version-header)
 246        x-face-add-x-face-version-header
 247        (x-face-insert-version-header)))
 248
 249 (defun wl-draft-setup ()
 250   (let ((field wl-draft-fields)
 251         ret-val)
 252     (while field
 253       (setq ret-val (append ret-val
 254                             (list (cons (concat (car field) " ")
 255                                         (concat (car field) " ")))))
 256       (setq field (cdr field)))
 257     (setq wl-draft-field-completion-list ret-val)))
 258
 259 (defun wl-draft-make-mail-followup-to (recipients)
 260   (if (elmo-list-member
 261        (or wl-user-mail-address-list
 262            (list (wl-address-header-extract-address wl-from)))
 263        recipients)
 264       (let ((rlist (elmo-list-delete
 265                     (or wl-user-mail-address-list
 266                         (list (wl-address-header-extract-address wl-from)))
 267                     (copy-sequence recipients))))
 268         (if (elmo-list-member rlist (mapcar 'downcase
 269                                             wl-subscribed-mailing-list))
 270             rlist
 271           (append rlist (list (wl-address-header-extract-address
 272                                wl-from)))))
 273     recipients))
 274
 275 (defun wl-draft-delete-myself-from-cc (to cc)
 276   (let ((myself (or wl-user-mail-address-list
 277                     (list (wl-address-header-extract-address wl-from)))))
 278     (if wl-draft-always-delete-myself
 279         (elmo-list-delete myself cc)
 280       (if (elmo-list-member myself cc)
 281           (if (elmo-list-member (append to cc)
 282                                 (mapcar 'downcase wl-subscribed-mailing-list))
 283               ;; member list is contained in recipients.
 284               (elmo-list-delete myself cc)
 285             cc
 286             )
 287         cc))))
 288
 289 (defun wl-draft-forward (original-subject summary-buf)
 290   (let (references)
 291     (with-current-buffer (wl-message-get-original-buffer)
 292       (setq references (nconc
 293                         (std11-field-bodies '("References" "In-Reply-To"))
 294                         (list (std11-field-body "Message-Id"))))
 295       (setq references (delq nil references)
 296             references (mapconcat 'identity references " ")
 297             references (wl-draft-parse-msg-id-list-string references)
 298             references (wl-delete-duplicates references)
 299             references (if references
 300                            (mapconcat 'identity references "\n\t"))))
 301     (wl-draft "" (concat "Forward: " original-subject)
 302               nil nil references nil nil nil nil nil nil summary-buf))
 303   (goto-char (point-max))
 304   (wl-draft-insert-message)
 305   (mail-position-on-field "To"))
 306
 307 (defun wl-draft-strip-subject-re (subject)
 308   "Remove \"Re:\" from subject lines. Shamelessly copied from Gnus"
 309   (if (string-match wl-subject-prefix-regexp subject)
 310       (substring subject (match-end 0))
 311     subject))
 312
 313 (defun wl-draft-reply (buf no-arg summary-buf)
 314   ""
 315 ;;;(save-excursion
 316   (let (r-list
 317         (eword-lexical-analyzer '(eword-analyze-quoted-string
 318                                   eword-analyze-domain-literal
 319                                   eword-analyze-comment
 320                                   eword-analyze-spaces
 321                                   eword-analyze-special
 322                                   eword-analyze-encoded-word
 323                                   eword-analyze-atom))
 324         to mail-followup-to cc subject in-reply-to references newsgroups
 325         from to-alist cc-alist)
 326     (set-buffer buf)
 327     (setq from (wl-address-header-extract-address (std11-field-body "From")))
 328     (setq r-list
 329           (if (wl-address-user-mail-address-p from)
 330               (if no-arg wl-draft-reply-myself-without-argument-list
 331                 wl-draft-reply-myself-with-argument-list)
 332             (if no-arg wl-draft-reply-without-argument-list
 333               wl-draft-reply-with-argument-list)))
 334     (catch 'done
 335       (while r-list
 336         (when (let ((condition (car (car r-list))))
 337                 (cond ((stringp condition)
 338                        (std11-field-body condition))
 339                       ((listp condition)
 340                        (catch 'done
 341                          (while condition
 342                            (if (not (std11-field-body (car condition)))
 343                                (throw 'done nil))
 344                            (setq condition (cdr condition)))
 345                          t))
 346                       ((symbolp condition)
 347                        (funcall condition))))
 348           (let ((r-to-list (nth 0 (cdr (car r-list))))
 349                 (r-cc-list (nth 1 (cdr (car r-list))))
 350                 (r-ng-list (nth 2 (cdr (car r-list)))))
 351             (when (and (member "Followup-To" r-ng-list)
 352                        (string= (std11-field-body "Followup-To") "poster"))
 353               (setq r-to-list (cons "From" r-to-list))
 354               (setq r-ng-list (delete "Followup-To" (copy-sequence r-ng-list))))
 355             (setq to (wl-concat-list (cons to
 356                                            (elmo-multiple-fields-body-list
 357                                             r-to-list))
 358                                      ","))
 359             (setq cc (wl-concat-list (cons cc
 360                                            (elmo-multiple-fields-body-list
 361                                             r-cc-list))
 362                                      ","))
 363             (setq newsgroups (wl-concat-list (cons newsgroups
 364                                                    (std11-field-bodies
 365                                                     r-ng-list))
 366                                              ",")))
 367           (throw 'done nil))
 368         (setq r-list (cdr r-list)))
 369       (error "No match field: check your `wl-draft-reply-without-argument-list'"))
 370     (setq subject (std11-field-body "Subject"))
 371     (setq to (wl-parse-addresses to)
 372           cc (wl-parse-addresses cc))
 373     (with-temp-buffer                   ; to keep raw buffer unibyte.
 374       (elmo-set-buffer-multibyte default-enable-multibyte-characters)
 375       (setq subject (or (and subject
 376                              (eword-decode-string
 377                               (decode-mime-charset-string
 378                                subject
 379                                wl-mime-charset)))))
 380       (setq to-alist
 381             (mapcar
 382              '(lambda (addr)
 383                 (setq addr (eword-extract-address-components addr))
 384                 (cons (nth 1 addr)
 385                       (if (nth 0 addr)
 386                           (concat
 387                            (wl-address-quote-specials (nth 0 addr))
 388                            " <" (nth 1 addr) ">")
 389                         (nth 1 addr))))
 390              to))
 391       (setq cc-alist
 392             (mapcar
 393              '(lambda (addr)
 394                 (setq addr (eword-extract-address-components addr))
 395                 (cons (nth 1 addr)
 396                       (if (nth 0 addr)
 397                           (concat
 398                            (wl-address-quote-specials (nth 0 addr))
 399                            " <" (nth 1 addr) ">")
 400                         (nth 1 addr))))
 401              cc)))
 402     (and subject wl-reply-subject-prefix
 403          (setq subject (concat wl-reply-subject-prefix
 404                                (wl-draft-strip-subject-re subject))))
 405     (setq in-reply-to (std11-field-body "Message-Id"))
 406     (setq references (nconc
 407                       (std11-field-bodies '("References" "In-Reply-To"))
 408                       (list in-reply-to)))
 409     (setq to (delq nil (mapcar 'car to-alist)))
 410     (setq cc (delq nil (mapcar 'car cc-alist)))
 411     ;; if subscribed mailing list is contained in cc or to
 412     ;; and myself is contained in cc,
 413     ;; delete myself from cc.
 414     (setq cc (wl-draft-delete-myself-from-cc to cc))
 415     (if wl-insert-mail-followup-to
 416         (progn
 417           (setq mail-followup-to
 418                 (wl-draft-make-mail-followup-to (append to cc)))
 419           (setq mail-followup-to (wl-delete-duplicates mail-followup-to
 420                                                        nil t))))
 421     (setq newsgroups (wl-parse newsgroups
 422                                "[ \t\f\r\n,]*\\([^ \t\f\r\n,]+\\)")
 423           newsgroups (wl-delete-duplicates newsgroups)
 424           newsgroups (if newsgroups (mapconcat 'identity newsgroups ",")))
 425     (setq to (wl-delete-duplicates to nil t))
 426     (setq cc (wl-delete-duplicates
 427               (append (wl-delete-duplicates cc nil t)
 428                       to (copy-sequence to))
 429               t t))
 430     (and to (setq to (mapconcat
 431                       '(lambda (addr)
 432                          (if wl-draft-reply-use-address-with-full-name
 433                              (or (cdr (assoc addr to-alist)) addr)
 434                            addr))
 435                       to ",\n\t")))
 436     (and cc (setq cc (mapconcat
 437                       '(lambda (addr)
 438                          (if wl-draft-reply-use-address-with-full-name
 439                              (or (cdr (assoc addr cc-alist)) addr)
 440                            addr))
 441                       cc ",\n\t")))
 442     (and mail-followup-to
 443          (setq mail-followup-to
 444                (mapconcat
 445                 '(lambda (addr)
 446                    (if wl-draft-reply-use-address-with-full-name
 447                        (or (cdr (assoc addr (append to-alist cc-alist))) addr)
 448                      addr))
 449                 mail-followup-to ",\n\t")))
 450     (and (null to) (setq to cc cc nil))
 451     (setq references (delq nil references)
 452           references (mapconcat 'identity references " ")
 453           references (wl-draft-parse-msg-id-list-string references)
 454           references (wl-delete-duplicates references)
 455           references (if references
 456                          (mapconcat 'identity references "\n\t")))
 457     (wl-draft
 458      to subject in-reply-to cc references newsgroups mail-followup-to
 459      nil nil nil nil summary-buf)
 460     (setq wl-draft-reply-buffer buf))
 461   (run-hooks 'wl-reply-hook))
 462
 463 (defun wl-draft-add-references ()
 464   (let* ((mes-id (save-excursion
 465                    (set-buffer mail-reply-buffer)
 466                    (std11-field-body "message-id")))
 467          (ref (std11-field-body "References"))
 468          (ref-list nil) (st nil))
 469     (when (and mes-id ref)
 470       (while (string-match "<[^>]+>" ref st)
 471         (setq ref-list
 472               (cons (substring ref (match-beginning 0) (setq st (match-end 0)))
 473                     ref-list)))
 474       (if (and ref-list
 475                (member mes-id ref-list))
 476           (setq mes-id nil)))
 477     (when mes-id
 478       (save-excursion
 479         (when (mail-position-on-field "References")
 480           (forward-line)
 481           (while (looking-at "^[ \t]")
 482             (forward-line))
 483           (setq mes-id (concat "\t" mes-id "\n")))
 484         (insert mes-id))
 485       t)))
 486
 487 (defun wl-draft-yank-from-mail-reply-buffer (decode-it
 488                                              &optional ignored-fields)
 489   (interactive)
 490   (save-restriction
 491     (narrow-to-region (point)(point))
 492     (insert
 493      (save-excursion
 494        (set-buffer mail-reply-buffer)
 495        (if decode-it
 496            (decode-mime-charset-region (point-min) (point-max)
 497                                        wl-mime-charset))
 498        (buffer-substring-no-properties
 499         (point-min) (point-max))))
 500     (when ignored-fields
 501       (goto-char (point-min))
 502       (wl-draft-delete-fields ignored-fields))
 503     (goto-char (point-max))
 504     (push-mark)
 505     (goto-char (point-min)))
 506   (let ((beg (point)))
 507     (cond (mail-citation-hook (run-hooks 'mail-citation-hook))
 508           (mail-yank-hooks (run-hooks 'mail-yank-hooks))
 509           (t (and wl-draft-cite-func
 510                   (funcall wl-draft-cite-func)))) ; default cite
 511     (run-hooks 'wl-draft-cited-hook)
 512     (and wl-draft-add-references
 513          (if (wl-draft-add-references)
 514              (wl-highlight-headers 'for-draft)))
 515     (if wl-highlight-body-too
 516         (wl-highlight-body-region beg (point-max)))))
 517
 518 (defun wl-draft-confirm ()
 519   "Confirm send message."
 520   (interactive)
 521   (y-or-n-p (format "Send current draft as %s? "
 522                     (if (wl-message-mail-p)
 523                         (if (wl-message-news-p) "Mail and News" "Mail")
 524                       "News"))))
 525
 526 (defun wl-message-news-p ()
 527   "If exist valid Newsgroups field, return non-nil."
 528   (std11-field-body "Newsgroups"))
 529
 530 (defun wl-message-field-exists-p (field)
 531   "If FIELD exist and FIELD value is not empty, return non-nil."
 532   (let ((value (std11-field-body field)))
 533     (and value
 534          (not (string= value "")))))
 535
 536 (defun wl-message-mail-p ()
 537   "If exist To, Cc or Bcc field, return non-nil."
 538   (or (wl-message-field-exists-p "To")
 539       (wl-message-field-exists-p "Cc")
 540       (wl-message-field-exists-p "Bcc")
 541 ;;; This may be needed..
 542 ;;;   (wl-message-field-exists-p "Fcc")
 543       ))
 544
 545 (defun wl-draft-open-file (&optional file)
 546   "Open FILE for edit."
 547   (interactive)
 548 ;;;(interactive "*fFile to edit: ")
 549   (wl-draft-edit-string (elmo-get-file-string
 550                          (or file
 551                              (read-file-name "File to edit: "
 552                                              (or wl-tmp-dir "~/"))))))
 553
 554 (defun wl-draft-edit-string (string)
 555   (let ((cur-buf (current-buffer))
 556         (tmp-buf (get-buffer-create " *wl-draft-edit-string*"))
 557         to subject in-reply-to cc references newsgroups mail-followup-to
 558         content-type content-transfer-encoding
 559         body-beg buffer-read-only
 560         )
 561     (set-buffer tmp-buf)
 562     (erase-buffer)
 563     (insert string)
 564     (setq to (std11-field-body "To"))
 565     (setq to (and to
 566                   (eword-decode-string
 567                    (decode-mime-charset-string
 568                     to
 569                     wl-mime-charset))))
 570     (setq subject (std11-field-body "Subject"))
 571     (setq subject (and subject
 572                        (eword-decode-string
 573                         (decode-mime-charset-string
 574                          subject
 575                          wl-mime-charset))))
 576     (setq in-reply-to (std11-field-body "In-Reply-To"))
 577     (setq cc (std11-field-body "Cc"))
 578     (setq cc (and cc
 579                   (eword-decode-string
 580                    (decode-mime-charset-string
 581                     cc
 582                     wl-mime-charset))))
 583     (setq references (std11-field-body "References"))
 584     (setq newsgroups (std11-field-body "Newsgroups"))
 585     (setq mail-followup-to (std11-field-body "Mail-Followup-To"))
 586     (setq content-type (std11-field-body "Content-Type"))
 587     (setq content-transfer-encoding (std11-field-body "Content-Transfer-Encoding"))
 588     (goto-char (point-min))
 589     (or (re-search-forward "\n\n" nil t)
 590         (search-forward (concat mail-header-separator "\n") nil t))
 591     (unwind-protect
 592         (set-buffer
 593          (wl-draft to subject in-reply-to cc references newsgroups
 594                    mail-followup-to
 595                    content-type content-transfer-encoding
 596                    (buffer-substring (point) (point-max))
 597                    'edit-again
 598                    ))
 599       (and to (mail-position-on-field "To"))
 600       (delete-other-windows)
 601       (kill-buffer tmp-buf)))
 602   (setq buffer-read-only nil) ;;??
 603   (run-hooks 'wl-draft-reedit-hook))
 604
 605 (defun wl-draft-insert-current-message (dummy)
 606   (interactive)
 607   (let ((mail-reply-buffer (wl-message-get-original-buffer))
 608         mail-citation-hook mail-yank-hooks
 609         wl-draft-add-references wl-draft-cite-func)
 610     (if (eq 0
 611             (save-excursion
 612               (set-buffer mail-reply-buffer)
 613               (buffer-size)))
 614         (error "No current message")
 615       (wl-draft-yank-from-mail-reply-buffer nil
 616                                             wl-ignored-forwarded-headers))))
 617
 618 (defun wl-draft-insert-get-message (dummy)
 619   (let ((fld (completing-read
 620               "Folder name: "
 621               (if (memq 'read-folder wl-use-folder-petname)
 622                   (wl-folder-get-entity-with-petname)
 623                 wl-folder-entity-hashtb)
 624               nil nil wl-default-spec
 625               'wl-read-folder-hist))
 626         (number (call-interactively
 627                  (function (lambda (num)
 628                              (interactive "nNumber: ")
 629                              num))))
 630         (mail-reply-buffer (get-buffer-create "*wl-draft-insert-get-message*"))
 631         mail-citation-hook mail-yank-hooks
 632         wl-draft-cite-func)
 633     (unwind-protect
 634         (progn
 635           (save-excursion
 636             (elmo-read-msg-with-cache fld number mail-reply-buffer nil))
 637           (wl-draft-yank-from-mail-reply-buffer nil))
 638       (kill-buffer mail-reply-buffer))))
 639
 640 ;;
 641 ;; default body citation func
 642 ;;
 643 (defun wl-default-draft-cite ()
 644   (let ((mail-yank-ignored-headers "[^:]+:")
 645         (mail-yank-prefix "> ")
 646         (summary-buf wl-current-summary-buffer)
 647         (message-buf (get-buffer (wl-current-message-buffer)))
 648         from date cite-title num entity)
 649     (if (and summary-buf
 650              (buffer-live-p summary-buf)
 651              message-buf
 652              (buffer-live-p message-buf))
 653         (progn
 654           (save-excursion
 655             (set-buffer summary-buf)
 656             (setq num
 657                   (save-excursion
 658                     (set-buffer message-buf)
 659                     wl-message-buffer-cur-number))
 660             (setq entity (assoc (cdr (assq num
 661                                            (elmo-msgdb-get-number-alist
 662                                             wl-summary-buffer-msgdb)))
 663                                 (elmo-msgdb-get-overview
 664                                  wl-summary-buffer-msgdb)))
 665             (setq from (elmo-msgdb-overview-entity-get-from entity))
 666             (setq date (elmo-msgdb-overview-entity-get-date entity)))
 667           (setq cite-title (format "At %s,\n%s wrote:"
 668                                    (or date "some time ago")
 669                                    (wl-summary-from-func-internal
 670                                     (or from "you"))))))
 671     (and cite-title
 672          (insert cite-title "\n"))
 673     (mail-indent-citation)))
 674
 675 (defvar wl-draft-buffer nil "Draft buffer to yank content")
 676 (defun wl-draft-yank-to-draft-buffer (buffer)
 677   "Yank BUFFER content to `wl-draft-buffer'."
 678   (set-buffer wl-draft-buffer)
 679   (let ((mail-reply-buffer buffer))
 680     (wl-draft-yank-from-mail-reply-buffer nil)
 681     (kill-buffer buffer)))
 682
 683 (defun wl-draft-yank-original (&optional arg)
 684   "Yank original message."
 685   (interactive "P")
 686   (if arg
 687       (let (buf mail-reply-buffer)
 688         (elmo-set-work-buf
 689          (yank)
 690          (setq buf (current-buffer)))
 691         (setq mail-reply-buffer buf)
 692         (wl-draft-yank-from-mail-reply-buffer nil))
 693     (wl-draft-yank-current-message-entity)))
 694
 695 (defun wl-draft-hide (editing-buffer)
 696   "Hide the editing draft buffer if possible."
 697   (interactive)
 698   (when (and editing-buffer
 699              (buffer-live-p editing-buffer))
 700     (set-buffer editing-buffer)
 701     (let ((sum-buf wl-draft-buffer-cur-summary-buffer)
 702           fld-buf sum-win fld-win)
 703       (if (and wl-draft-use-frame
 704                (> (length (visible-frame-list)) 1))
 705           ;; hide draft frame
 706           (delete-frame)
 707         ;; hide draft window
 708         (or (one-window-p)
 709             (delete-window)))
 710       ;; stay folder window if required
 711       (when wl-stay-folder-window
 712         (if (setq fld-buf (get-buffer wl-folder-buffer-name))
 713             (if (setq fld-win (get-buffer-window fld-buf))
 714                 (select-window fld-win)
 715               (if wl-draft-resume-folder-window ;; resume folder window
 716                   (switch-to-buffer fld-buf)))))
 717       (if (buffer-live-p sum-buf)
 718           (if (setq sum-win (get-buffer-window sum-buf t))
 719               ;; if Summary is on the frame, select it.
 720               (select-window sum-win)
 721             ;; if summary is not on the frame, switch to it.
 722             (if (and wl-stay-folder-window
 723                      (or wl-draft-resume-folder-window fld-win))
 724                 (wl-folder-select-buffer sum-buf)
 725               (switch-to-buffer sum-buf)))))))
 726
 727 (defun wl-draft-delete (editing-buffer)
 728   "kill the editing draft buffer and delete the file corresponds to it."
 729   (save-excursion
 730     (when editing-buffer
 731       (set-buffer editing-buffer)
 732       (if wl-draft-buffer-file-name
 733           (progn
 734             (if (file-exists-p wl-draft-buffer-file-name)
 735                 (delete-file wl-draft-buffer-file-name))
 736             (let ((msg (and wl-draft-buffer-file-name
 737                             (string-match "[0-9]+$" wl-draft-buffer-file-name)
 738                             (string-to-int
 739                              (elmo-match-string 0 wl-draft-buffer-file-name)))))
 740               (wl-draft-config-info-operation msg 'delete))))
 741       (set-buffer-modified-p nil)               ; force kill
 742       (kill-buffer editing-buffer))))
 743
 744 (defun wl-draft-kill (&optional force-kill)
 745   "Kill current draft buffer and quit editing."
 746   (interactive "P")
 747   (save-excursion
 748     (when (and (or (eq major-mode 'wl-draft-mode)
 749                    (eq major-mode 'mail-mode))
 750                (or force-kill
 751                    (y-or-n-p "Kill Current Draft?")))
 752       (let ((cur-buf (current-buffer)))
 753         (wl-draft-hide cur-buf)
 754         (wl-draft-delete cur-buf)))
 755     (message "")))
 756
 757 (defun wl-draft-fcc ()
 758   "Add a new FCC field, with file name completion."
 759   (interactive)
 760   (or (mail-position-on-field "fcc" t)  ;Put new field after exiting FCC.
 761       (mail-position-on-field "to"))
 762   (insert "\nFCC: "))
 763
 764 ;; function for wl-sent-message-via
 765
 766 (defmacro wl-draft-sent-message-p (type)
 767   (` (eq (nth 1 (assq (, type) wl-sent-message-via)) 'sent)))
 768
 769 (defmacro wl-draft-set-sent-message (type result &optional server-port)
 770   (` (let ((element (assq (, type) wl-sent-message-via)))
 771        (if element
 772            (unless (eq (nth 1 element) (, result))
 773              (setcdr element (list (, result) (, server-port)))
 774              (setq wl-sent-message-modified t))
 775          (push (list (, type) (, result) (, server-port)) wl-sent-message-via)
 776          (setq wl-sent-message-modified t)))))
 777
 778 (defun wl-draft-sent-message-results ()
 779   (let ((results wl-sent-message-via)
 780         unplugged-via sent-via)
 781     (while results
 782       (cond ((eq (nth 1 (car results)) 'unplugged)
 783              (push (caar results) unplugged-via))
 784             ((eq (nth 1 (car results)) 'sent)
 785              (push (caar results) sent-via)))
 786       (setq results (cdr results)))
 787     (list unplugged-via sent-via)))
 788
 789 (defun wl-draft-write-sendlog (status proto server to id)
 790   "Write send log file, if `wl-draft-sendlog' is non-nil."
 791   (when wl-draft-sendlog
 792     (save-excursion
 793       (let* ((tmp-buf (get-buffer-create " *wl-draft-sendlog*"))
 794              (filename (expand-file-name wl-draft-sendlog-filename
 795                                          elmo-msgdb-dir))
 796              (filesize (nth 7 (file-attributes filename)))
 797              (server (if server (concat " server=" server) ""))
 798              (to (if to (cond
 799                          ((memq proto '(fcc queue))
 800                           (format " folder=\"%s\"" to))
 801                          ((eq proto 'nntp)
 802                           (format " ng=<%s>" to))
 803                          (t
 804                           (concat " to="
 805                                   (mapconcat
 806                                    'identity
 807                                    (mapcar '(lambda(x) (format "<%s>" x)) to)
 808                                    ","))))
 809                    ""))
 810              (id (if id (concat " id=" id) ""))
 811              (time (wl-sendlog-time)))
 812         (set-buffer tmp-buf)
 813         (erase-buffer)
 814         (insert (format "%s proto=%s stat=%s%s%s%s\n"
 815                         time proto status server to id))
 816         (if (and wl-draft-sendlog-max-size filesize
 817                  (> filesize wl-draft-sendlog-max-size))
 818             (rename-file filename (concat filename ".old") t))
 819         (if (file-writable-p filename)
 820             (write-region (point-min) (point-max)
 821                           filename t 'no-msg)
 822           (message (format "%s is not writable." filename)))
 823         (kill-buffer tmp-buf)))))
 824
 825 (defun wl-draft-get-header-delimiter (&optional delete)
 826   ;; If DELETE is non-nil, replace the header delimiter with a blank line
 827   (let (delimline)
 828     (goto-char (point-min))
 829     (when (re-search-forward
 830            (concat "^" (regexp-quote mail-header-separator) "$\\|^$") nil t)
 831       (replace-match "")
 832       (if delete
 833           (forward-char -1))
 834       (setq delimline (point-marker)))
 835     delimline))
 836
 837 (defun wl-draft-send-mail-with-qmail ()
 838   "Pass the prepared message buffer to qmail-inject.
 839 Refer to the documentation for the variable `send-mail-function'
 840 to find out how to use this."
 841   (if (and wl-draft-qmail-send-plugged
 842            (not (elmo-plugged-p)))
 843       (wl-draft-set-sent-message 'mail 'unplugged)
 844     ;; send the message
 845     (let ((id (std11-field-body "Message-ID"))
 846           (to (std11-field-body "To")))
 847       (case
 848           (as-binary-process
 849            (apply
 850             'call-process-region 1 (point-max) wl-qmail-inject-program
 851             nil nil nil
 852             wl-qmail-inject-args))
 853         ;; qmail-inject doesn't say anything on it's stdout/stderr,
 854         ;; we have to look at the retval instead
 855         (0   (progn
 856                (wl-draft-set-sent-message 'mail 'sent)
 857                (wl-draft-write-sendlog 'ok 'qmail nil (list to) id)))
 858         (1   (error "qmail-inject reported permanent failure"))
 859         (111 (error "qmail-inject reported transient failure"))
 860         ;; should never happen
 861         (t   (error "qmail-inject reported unknown failure"))))))
 862
 863 (defun wl-draft-parse-msg-id-list-string (string)
 864   "Get msg-id list from STRING."
 865   (let ((parsed (std11-parse-msg-ids-string string))
 866         tokens msg-id msg-id-list)
 867     (while parsed
 868       (setq msg-id nil)
 869       (when (eq (car (car parsed)) 'msg-id)
 870         (setq tokens (cdr (car parsed)))
 871         (while tokens
 872           (if (or (eq (car (car tokens)) 'atom)
 873                   (eq (car (car tokens)) 'specials))
 874               (setq msg-id (concat msg-id (cdr (car tokens)))))
 875           (setq tokens (cdr tokens))))
 876       (if msg-id (setq msg-id-list (cons (concat "<" msg-id ">")
 877                                          msg-id-list)))
 878       (setq parsed (cdr parsed)))
 879     (nreverse msg-id-list)))
 880
 881 (defun wl-draft-parse-mailbox-list (field &optional remove-group-list)
 882   "Get mailbox list of FIELD from current buffer.
 883 The buffer is expected to be narrowed to just the headers of the message.
 884 If optional argument REMOVE-GROUP-LIST is non-nil, remove group list content
 885 from current buffer."
 886   (save-excursion
 887     (let ((case-fold-search t)
 888           (inhibit-read-only t)
 889           addresses address
 890           mailbox-list beg seq has-group-list)
 891       (goto-char (point-min))
 892       (while (re-search-forward (concat "^" (regexp-quote field) "[\t ]*:")
 893                                 nil t)
 894         (setq beg (point))
 895         (re-search-forward "^[^ \t]" nil 'move)
 896         (beginning-of-line)
 897         (skip-chars-backward "\n")
 898         (setq seq (std11-lexical-analyze
 899                    (buffer-substring-no-properties beg (point))))
 900         (setq addresses (std11-parse-addresses seq))
 901         (while addresses
 902           (cond ((eq (car (car addresses)) 'group)
 903                  (setq has-group-list t)
 904                  (setq mailbox-list
 905                        (nconc mailbox-list
 906                               (mapcar
 907                                'std11-address-string
 908                                (nth 2 (car addresses))))))
 909                 ((eq (car (car addresses)) 'mailbox)
 910                  (setq address (nth 1 (car addresses)))
 911                  (setq mailbox-list
 912                        (nconc mailbox-list
 913                               (list
 914                                (std11-addr-to-string
 915                                 (if (eq (car address) 'phrase-route-addr)
 916                                     (nth 2 address)
 917                                   (cdr address))))))))
 918           (setq addresses (cdr addresses)))
 919         (when (and remove-group-list has-group-list)
 920           (delete-region beg (point))
 921           (insert (wl-address-string-without-group-list-contents seq))))
 922       mailbox-list)))
 923
 924 (defun wl-draft-deduce-address-list (buffer header-start header-end)
 925   "Get address list suitable for smtp RCPT TO:<address>.
 926 Group list content is removed if `wl-draft-remove-group-list-contents' is
 927 non-nil."
 928   (let ((fields        '("to" "cc" "bcc"))
 929         (resent-fields '("resent-to" "resent-cc" "resent-bcc"))
 930         (case-fold-search t)
 931         addrs recipients)
 932     (save-excursion
 933       (save-restriction
 934         (narrow-to-region header-start header-end)
 935         (goto-char (point-min))
 936         (save-excursion
 937           (if (re-search-forward "^resent-to[\t ]*:" nil t)
 938               (setq fields resent-fields)))
 939         (while fields
 940           (setq recipients
 941                 (nconc recipients
 942                        (wl-draft-parse-mailbox-list
 943                         (car fields)
 944                         wl-draft-remove-group-list-contents)))
 945           (setq fields (cdr fields)))
 946         recipients))))
 947
 948 ;;
 949 ;; from Semi-gnus
 950 ;;
 951 (defun wl-draft-send-mail-with-smtp ()
 952   "Send the prepared message buffer with SMTP."
 953   (require 'smtp)
 954   (let* ((errbuf (if mail-interactive
 955                      (generate-new-buffer " smtp errors")
 956                    0))
 957          (case-fold-search t)
 958          (default-case-fold-search t)
 959          (sender (or wl-envelope-from
 960                      (wl-address-header-extract-address wl-from)))
 961          (delimline (save-excursion
 962                       (goto-char (point-min))
 963                       (re-search-forward
 964                        (concat "^" (regexp-quote mail-header-separator)
 965                                "$\\|^$") nil t)
 966                       (point-marker)))
 967          (smtp-server
 968           (or wl-smtp-posting-server
 969               ;; Compatibility stuff for FLIM 1.12.5 or earlier.
 970               ;; They don't accept a function as the value of `smtp-server'.
 971               (if (functionp smtp-server)
 972                   (funcall
 973                    smtp-server
 974                    sender
 975                    ;; no harm..
 976                    (let (wl-draft-remove-group-list-contents)
 977                      (wl-draft-deduce-address-list
 978                       (current-buffer) (point-min) delimline)))
 979                 (or smtp-server "localhost"))))
 980          (smtp-service (or wl-smtp-posting-port smtp-service))
 981          (smtp-local-domain (or smtp-local-domain wl-local-domain))
 982          (id (std11-field-body "message-id"))
 983          recipients)
 984     (if (not (elmo-plugged-p smtp-server smtp-service))
 985         (wl-draft-set-sent-message 'mail 'unplugged
 986                                    (cons smtp-server smtp-service))
 987       (unwind-protect
 988           (save-excursion
 989             ;; Instead of `smtp-deduce-address-list'.
 990             (setq recipients (wl-draft-deduce-address-list
 991                               (current-buffer) (point-min) delimline))
 992             (unless recipients (error "No recipients"))
 993             ;; Insert an extra newline if we need it to work around
 994             ;; Sun's bug that swallows newlines.
 995             (goto-char (1+ delimline))
 996             (if (eval mail-mailer-swallows-blank-line)
 997                 (newline))
 998 ;;;         (run-hooks 'wl-mail-send-pre-hook)
 999             (if mail-interactive
1000                 (save-excursion
1001                   (set-buffer errbuf)
1002                   (erase-buffer)))
1003             (wl-draft-delete-field "bcc" delimline)
1004             (wl-draft-delete-field "resent-bcc" delimline)
1005             (let (process-connection-type)
1006               (as-binary-process
1007                (when recipients
1008                  (wl-smtp-extension-bind
1009                   (let ((err (smtp-via-smtp sender recipients
1010                                             (current-buffer))))
1011                     (when (not (eq err t))
1012                       (wl-draft-write-sendlog 'failed 'smtp smtp-server
1013                                               recipients id)
1014                       (error "Sending failed; SMTP protocol error:%s" err))))
1015                  (wl-draft-set-sent-message 'mail 'sent)
1016                  (wl-draft-write-sendlog
1017                   'ok 'smtp smtp-server recipients id)))))
1018         (if (bufferp errbuf)
1019             (kill-buffer errbuf))))))
1020
1021 (defun wl-draft-send-mail-with-pop-before-smtp ()
1022   "Send the prepared message buffer with POP-before-SMTP."
1023   (require 'elmo-pop3)
1024   (condition-case ()
1025       (elmo-pop3-get-session
1026        (list 'pop3
1027              (or wl-pop-before-smtp-user
1028                  elmo-default-pop3-user)
1029              (or wl-pop-before-smtp-authenticate-type
1030                  elmo-default-pop3-authenticate-type)
1031              (or wl-pop-before-smtp-server
1032                  elmo-default-pop3-server)
1033              (or wl-pop-before-smtp-port
1034                  elmo-default-pop3-port)
1035              (or wl-pop-before-smtp-stream-type
1036                  elmo-default-pop3-stream-type)))
1037     (error))
1038   (wl-draft-send-mail-with-smtp))
1039
1040 (defun wl-draft-insert-required-fields (&optional force-msgid)
1041   "Insert Message-ID, Date, and From field.
1042 If FORCE-MSGID, ignore 'wl-insert-message-id'."
1043   ;; Insert Message-Id field...
1044   (goto-char (point-min))
1045   (when (and (or force-msgid
1046                  wl-insert-message-id)
1047              (not (re-search-forward "^Message-ID[ \t]*:" nil t)))
1048     (insert (concat "Message-ID: "
1049                     (wl-draft-make-message-id-string)
1050                     "\n")))
1051   ;; Insert date field.
1052   (goto-char (point-min))
1053   (or (re-search-forward "^Date[ \t]*:" nil t)
1054       (wl-draft-insert-date-field))
1055   ;; Insert from field.
1056   (goto-char (point-min))
1057   (or (re-search-forward "^From[ \t]*:" nil t)
1058       (wl-draft-insert-from-field)))
1059
1060 (defun wl-draft-normal-send-func (editing-buffer kill-when-done)
1061   "Send the message in the current buffer."
1062   (save-restriction
1063     (std11-narrow-to-header mail-header-separator)
1064     (wl-draft-insert-required-fields)
1065     ;; Delete null fields.
1066     (goto-char (point-min))
1067     (while (re-search-forward "^[^ \t\n:]+:[ \t]*\n" nil t)
1068       (replace-match ""))
1069     ;; ignore any blank lines in the header
1070     (while (re-search-forward "\n\n\n*" nil t)
1071       (replace-match "\n")))
1072   (run-hooks 'wl-mail-send-pre-hook) ;; X-PGP-Sig, Cancel-Lock
1073   (wl-draft-dispatch-message)
1074   (when kill-when-done
1075     ;; hide editing-buffer.
1076     (wl-draft-hide editing-buffer)
1077     ;; delete editing-buffer and its file.
1078     (wl-draft-delete editing-buffer)))
1079
1080 (defun wl-draft-dispatch-message (&optional mes-string)
1081   "Send the message in the current buffer.  Not modified the header fields."
1082   (let (delimline)
1083     (if (and wl-draft-verbose-send mes-string)
1084         (message mes-string))
1085     ;; get fcc folders.
1086     (setq delimline (wl-draft-get-header-delimiter t))
1087     (unless wl-draft-fcc-list
1088       (setq wl-draft-fcc-list (wl-draft-get-fcc-list delimline)))
1089     ;;
1090     (setq wl-sent-message-modified nil)
1091     (unwind-protect
1092         (progn
1093           (if (and (wl-message-mail-p)
1094                    (not (wl-draft-sent-message-p 'mail)))
1095               (funcall wl-draft-send-mail-func))
1096           (if (and (wl-message-news-p)
1097                    (not (wl-draft-sent-message-p 'news))
1098                    (not (wl-message-field-exists-p "Resent-to")))
1099               (funcall wl-draft-send-news-func)))
1100       ;;
1101       (let* ((status (wl-draft-sent-message-results))
1102              (unplugged-via (car status))
1103              (sent-via (nth 1 status)))
1104         ;; If one sent, process fcc folder.
1105         (if (and sent-via wl-draft-fcc-list)
1106             (progn
1107               (wl-draft-do-fcc (wl-draft-get-header-delimiter) wl-draft-fcc-list)
1108               (setq wl-draft-fcc-list nil))
1109           (if wl-draft-use-cache
1110               (let ((id (std11-field-body "Message-ID"))
1111                     (elmo-enable-disconnected-operation t))
1112                 (elmo-cache-save id nil nil nil))))
1113         ;; If one unplugged, append queue.
1114         (when (and unplugged-via
1115                    wl-sent-message-modified)
1116           (if wl-draft-enable-queuing
1117               (wl-draft-queue-append wl-sent-message-via)
1118             (error "Unplugged")))
1119         (when wl-draft-verbose-send
1120           (if (and unplugged-via sent-via);; combined message
1121               (progn
1122                 (setq wl-draft-verbose-msg
1123                       (format "Sending%s and Queuing%s..."
1124                               sent-via unplugged-via))
1125                 (message (concat wl-draft-verbose-msg "done")))
1126             (if mes-string
1127                 (message (concat mes-string
1128                                  (if sent-via "done" "failed")))))))))
1129   (not wl-sent-message-modified)) ;; return value
1130
1131 (defun wl-draft-raw-send (&optional kill-when-done force-pre-hook mes-string)
1132   "Force send current buffer as raw message."
1133   (interactive)
1134   (save-excursion
1135     (let (wl-interactive-send
1136 ;;;       wl-draft-verbose-send
1137           (wl-mail-send-pre-hook (and force-pre-hook wl-mail-send-pre-hook))
1138 ;;;       wl-news-send-pre-hook
1139           mail-send-hook
1140           mail-send-actions)
1141       (wl-draft-send kill-when-done mes-string))))
1142
1143 (defun wl-draft-clone-local-variables ()
1144   (let ((locals (buffer-local-variables))
1145         result)
1146     (while locals
1147       (when (and (consp (car locals))
1148                  (car (car locals))
1149                  (string-match wl-draft-clone-local-variable-regexp
1150                                (symbol-name (car (car locals)))))
1151         (wl-append result (list (car (car locals)))))
1152       (setq locals (cdr locals)))
1153     result))
1154
1155 (defun wl-draft-send (&optional kill-when-done mes-string)
1156   "Send current draft message.
1157 If optional argument is non-nil, current draft buffer is killed"
1158   (interactive)
1159   ;; Don't call this explicitly.
1160   ;; Added to 'wl-draft-send-hook (by teranisi)
1161   ;; (wl-draft-config-exec)
1162   (run-hooks 'wl-draft-send-hook)
1163   (when (or (not wl-interactive-send)
1164             (y-or-n-p "Send current draft. OK?"))
1165     (let ((send-mail-function 'wl-draft-raw-send)
1166           (editing-buffer (current-buffer))
1167           (sending-buffer (wl-draft-generate-clone-buffer
1168                            " *wl-draft-sending-buffer*"
1169                            (append wl-draft-config-variables
1170                                    (wl-draft-clone-local-variables))))
1171           (wl-draft-verbose-msg nil)
1172           err)
1173       (unwind-protect
1174           (save-excursion (set-buffer sending-buffer)
1175             (if (and (not (wl-message-mail-p))
1176                      (not (wl-message-news-p)))
1177                 (error "No recipient is specified"))
1178             (expand-abbrev) ; for mail-abbrevs
1179             (run-hooks 'mail-send-hook) ; translate buffer
1180             (if wl-draft-verbose-send
1181                 (message (or mes-string "Sending...")))
1182             (funcall wl-draft-send-func editing-buffer kill-when-done)
1183             ;; Now perform actions on successful sending.
1184             (while mail-send-actions
1185               (condition-case ()
1186                   (apply (car (car mail-send-actions))
1187                          (cdr (car mail-send-actions)))
1188                 (error))
1189               (setq mail-send-actions (cdr mail-send-actions)))
1190             (if (or (eq major-mode 'wl-draft-mode)
1191                     (eq major-mode 'mail-mode))
1192                 (local-set-key "\C-c\C-s" 'wl-draft-send)) ; override
1193             (if wl-draft-verbose-send
1194                 (message (concat (or wl-draft-verbose-msg
1195                                      mes-string "Sending...")
1196                                  "done"))))
1197         ;; kill sending buffer, anyway.
1198         (and (buffer-live-p sending-buffer)
1199              (kill-buffer sending-buffer))))))
1200
1201 (defun wl-draft-save ()
1202   "Save current draft."
1203   (interactive)
1204   (save-buffer)
1205   (wl-draft-config-info-operation
1206    (and (string-match "[0-9]+$" wl-draft-buffer-file-name)
1207         (string-to-int
1208          (elmo-match-string 0 wl-draft-buffer-file-name)))
1209    'save))
1210
1211 (defun wl-draft-mimic-kill-buffer ()
1212   "Kill the current (draft) buffer with query."
1213   (interactive)
1214   (let ((bufname (read-buffer (format "Kill buffer: (default %s) "
1215                                       (buffer-name))))
1216         wl-draft-use-frame)
1217     (if (or (not bufname)
1218             (string-equal bufname "")
1219             (string-equal bufname (buffer-name)))
1220         (wl-draft-save-and-exit)
1221       (kill-buffer bufname))))
1222
1223 (defun wl-draft-save-and-exit ()
1224   "Save current draft and exit current draft mode."
1225   (interactive)
1226   (wl-draft-save)
1227   (let ((editing-buffer (current-buffer)))
1228     (wl-draft-hide editing-buffer)
1229     (kill-buffer editing-buffer)))
1230
1231 (defun wl-draft-send-and-exit ()
1232   "Send current draft message and kill it."
1233   (interactive)
1234   (wl-draft-send t))
1235
1236 (defun wl-draft-send-from-toolbar ()
1237   (interactive)
1238   (let ((wl-interactive-send t))
1239     (wl-draft-send-and-exit)))
1240
1241 (defun wl-draft-delete-field (field &optional delimline)
1242   (wl-draft-delete-fields (regexp-quote field) delimline))
1243
1244 (defun wl-draft-delete-fields (regexp &optional delimline)
1245   (save-restriction
1246     (unless delimline
1247       (if (search-forward "\n\n" nil t)
1248           (setq delimline (point))
1249         (setq delimline (point-max))))
1250     (narrow-to-region (point-min) delimline)
1251     (goto-char (point-min))
1252     (let ((regexp (concat "^" regexp ":"))
1253           (case-fold-search t)
1254           last)
1255       (while (not (eobp))
1256         (if (looking-at regexp)
1257             (progn
1258               (delete-region
1259                (point)
1260                (progn
1261                  (forward-line 1)
1262                  (if (re-search-forward "^[^ \t]" nil t)
1263                      (goto-char (match-beginning 0))
1264                    (point-max)))))
1265           (forward-line 1)
1266           (if (re-search-forward "^[^ \t]" nil t)
1267               (goto-char (match-beginning 0))
1268             (point-max)))))))
1269
1270 (defun wl-draft-get-fcc-list (header-end)
1271   (let (fcc-list
1272         (case-fold-search t))
1273     (or (markerp header-end) (error "header-end must be a marker"))
1274     (save-excursion
1275       (goto-char (point-min))
1276       (while (re-search-forward "^FCC:[ \t]*" header-end t)
1277         (setq fcc-list
1278               (cons (buffer-substring-no-properties
1279                      (point)
1280                      (progn
1281                        (end-of-line)
1282                        (skip-chars-backward " \t")
1283                        (point)))
1284                     fcc-list))
1285         (save-match-data
1286           (wl-folder-confirm-existence (eword-decode-string (car fcc-list))))
1287         (delete-region (match-beginning 0)
1288                        (progn (forward-line 1) (point)))))
1289     fcc-list))
1290
1291 (defun wl-draft-do-fcc (header-end &optional fcc-list)
1292   (let ((send-mail-buffer (current-buffer))
1293         (tembuf (generate-new-buffer " fcc output"))
1294         (case-fold-search t)
1295         beg end)
1296     (or (markerp header-end) (error "header-end must be a marker"))
1297     (save-excursion
1298       (unless fcc-list
1299         (setq fcc-list (wl-draft-get-fcc-list header-end)))
1300       (set-buffer tembuf)
1301       (erase-buffer)
1302       ;; insert just the headers to avoid moving the gap more than
1303       ;; necessary (the message body could be arbitrarily huge.)
1304       (insert-buffer-substring send-mail-buffer 1 header-end)
1305       (wl-draft-insert-required-fields t)
1306       (goto-char (point-max))
1307       (insert-buffer-substring send-mail-buffer header-end)
1308       (let ((id (std11-field-body "Message-ID"))
1309             (elmo-enable-disconnected-operation t)
1310             cache-saved)
1311         (while fcc-list
1312           (unless (or cache-saved
1313                       (elmo-folder-plugged-p (car fcc-list)))
1314             (elmo-cache-save id nil nil nil) ;; for disconnected operation
1315             (setq cache-saved t))
1316           (if (elmo-append-msg (eword-decode-string (car fcc-list))
1317                                (buffer-substring
1318                                 (point-min) (point-max))
1319                                id)
1320               (wl-draft-write-sendlog 'ok 'fcc nil (car fcc-list) id)
1321             (wl-draft-write-sendlog 'failed 'fcc nil (car fcc-list) id))
1322           (setq fcc-list (cdr fcc-list)))))
1323     (kill-buffer tembuf)))
1324
1325 (defun wl-draft-on-field-p ()
1326   (if (< (point)
1327          (save-excursion
1328            (goto-char (point-min))
1329            (search-forward (concat "\n" mail-header-separator "\n") nil 0)
1330            (point)))
1331       (if (bolp)
1332           (if (bobp)
1333               t
1334             (save-excursion
1335               (forward-line -1)
1336               (if (or (looking-at ".*,[ \t]?$")
1337                       (looking-at "^[^ \t]+:[ \t]+.*:$")); group list name
1338                   nil t)))
1339         (let ((pos (point)))
1340           (save-excursion
1341             (beginning-of-line)
1342             (if (looking-at "^[ \t]")
1343                 nil
1344               (if (re-search-forward ":" pos t) nil t)))))))
1345
1346 (defun wl-draft-random-alphabet ()
1347   (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)))
1348     (nth (abs (% (random) 26)) alphabet)))
1349
1350 ;;;###autoload
1351 (defun wl-draft (&optional to subject in-reply-to cc references newsgroups
1352                            mail-followup-to
1353                            content-type content-transfer-encoding
1354                            body edit-again summary-buf)
1355   "Write and send mail/news message with Wanderlust."
1356   (interactive)
1357   (unless (featurep 'wl)
1358     (require 'wl))
1359   (unless wl-init
1360     (wl-load-profile))
1361   (wl-init 'wl-draft) ;; returns immediately if already initialized.
1362   (if (interactive-p)
1363       (setq summary-buf (wl-summary-get-buffer wl-summary-buffer-folder-name)))
1364   (let ((draft-folder-spec (elmo-folder-get-spec wl-draft-folder))
1365         buf-name file-name num wl-demo change-major-mode-hook)
1366     (if (not (eq (car draft-folder-spec) 'localdir))
1367         (error "%s folder cannot be used for draft folder" wl-draft-folder))
1368     (setq num (elmo-max-of-list (or (elmo-list-folder wl-draft-folder) '(0))))
1369     (setq num (+ 1 num))
1370     ;; To get unused buffer name.
1371     (while (get-buffer (concat wl-draft-folder "/" (int-to-string num)))
1372       (setq num (+ 1 num)))
1373     (setq buf-name (find-file-noselect
1374                     (setq file-name
1375                           (elmo-get-msg-filename wl-draft-folder
1376                                                  num))))
1377     (if wl-draft-use-frame
1378         (switch-to-buffer-other-frame buf-name)
1379       (switch-to-buffer buf-name))
1380     (set-buffer buf-name)
1381     (if (not (string-match (regexp-quote wl-draft-folder)
1382                            (buffer-name)))
1383         (rename-buffer (concat wl-draft-folder "/" (int-to-string num))))
1384     (if (or (eq wl-draft-reply-buffer-style 'full)
1385             (eq this-command 'wl-draft)
1386             (eq this-command 'wl-summary-write)
1387             (eq this-command 'wl-summary-write-current-newsgroup))
1388         (delete-other-windows))
1389     (auto-save-mode -1)
1390     (wl-draft-mode)
1391     (setq wl-sent-message-via nil)
1392     (if (stringp wl-from)
1393         (insert "From: " wl-from "\n"))
1394     (and (or (interactive-p)
1395              (eq this-command 'wl-summary-write)
1396              to)
1397          (insert "To: " (or to "") "\n"))
1398     (and cc (insert "Cc: " (or cc "") "\n"))
1399     (insert "Subject: " (or subject "") "\n")
1400     (and newsgroups (insert "Newsgroups: " newsgroups "\n"))
1401     (and mail-followup-to (insert "Mail-Followup-To: " mail-followup-to "\n"))
1402     (and wl-insert-mail-reply-to
1403          (insert "Mail-Reply-To: "
1404                  (wl-address-header-extract-address
1405                   wl-from) "\n"))
1406     (and in-reply-to (insert "In-Reply-To: " in-reply-to "\n"))
1407     (and references (insert "References: " references "\n"))
1408     (insert (funcall wl-generate-mailer-string-func)
1409             "\n")
1410     (setq wl-draft-buffer-file-name file-name)
1411     (if mail-default-reply-to
1412         (insert "Reply-To: " mail-default-reply-to "\n"))
1413     (if (or wl-bcc mail-self-blind)
1414         (insert "Bcc: " (or wl-bcc (user-login-name)) "\n"))
1415     (if wl-fcc
1416         (insert "FCC: " (if (functionp wl-fcc) (funcall wl-fcc) wl-fcc) "\n"))
1417     (if wl-organization
1418         (insert "Organization: " wl-organization "\n"))
1419     (and wl-auto-insert-x-face
1420          (file-exists-p wl-x-face-file)
1421          (wl-draft-insert-x-face-field-here))
1422     (if mail-default-headers
1423         (insert mail-default-headers))
1424     (if (not (= (preceding-char) ?\n))
1425         (insert ?\n))
1426     (if edit-again
1427         (let (start)
1428           (setq start (point))
1429           (when content-type
1430             (insert "Content-type: " content-type "\n"))
1431           (when content-transfer-encoding
1432             (insert "Content-Transfer-encoding: " content-transfer-encoding "\n"))
1433           (if (or content-type content-transfer-encoding)
1434               (insert "\n"))
1435           (and body (insert body))
1436           (save-restriction
1437             (narrow-to-region start (point))
1438             (and edit-again
1439                  (wl-draft-decode-message-in-buffer))
1440             (widen)
1441             (goto-char start)
1442             (put-text-property (point)
1443                                (progn
1444                                  (insert mail-header-separator "\n")
1445                                  (1- (point)))
1446                                'category 'mail-header-separator)))
1447       (put-text-property (point)
1448                          (progn
1449                            (insert mail-header-separator "\n")
1450                            (1- (point)))
1451                          'category 'mail-header-separator)
1452       (and body (insert body)))
1453     (if wl-on-nemacs
1454         (push-mark (point) t)
1455       (push-mark (point) t t))
1456     (as-binary-output-file
1457      (write-region (point-min)(point-max) wl-draft-buffer-file-name
1458                    nil t))
1459     (wl-draft-editor-mode)
1460     (wl-draft-overload-functions)
1461     (wl-highlight-headers 'for-draft)
1462     (goto-char (point-min))
1463     (setq wl-draft-config-exec-flag t)
1464     (if (interactive-p)
1465         (run-hooks 'wl-mail-setup-hook))
1466     (wl-user-agent-compose-internal) ;; user-agent
1467     (cond ((eq this-command 'wl-summary-write-current-newsgroup)
1468            (mail-position-on-field "Subject"))
1469           ((and (interactive-p) (null to))
1470            (mail-position-on-field "To"))
1471           (t
1472            (goto-char (point-max))))
1473     (setq wl-draft-buffer-cur-summary-buffer (or summary-buf
1474                                                  (get-buffer
1475                                                   wl-summary-buffer-name)))
1476     buf-name))
1477
1478 (defun wl-draft-elmo-nntp-send ()
1479   (let ((elmo-nntp-post-pre-hook wl-news-send-pre-hook)
1480         (elmo-default-nntp-user
1481          (or wl-nntp-posting-user elmo-default-nntp-user))
1482         (elmo-default-nntp-server
1483          (or wl-nntp-posting-server elmo-default-nntp-server))
1484         (elmo-default-nntp-port
1485          (or wl-nntp-posting-port elmo-default-nntp-port))
1486         (elmo-default-nntp-stream-type
1487          (or wl-nntp-posting-stream-type elmo-default-nntp-stream-type)))
1488     (if (not (elmo-plugged-p elmo-default-nntp-server elmo-default-nntp-port))
1489         (wl-draft-set-sent-message 'news 'unplugged
1490                                    (cons elmo-default-nntp-server
1491                                          elmo-default-nntp-port))
1492       (elmo-nntp-post elmo-default-nntp-server (current-buffer))
1493       (wl-draft-set-sent-message 'news 'sent)
1494       (wl-draft-write-sendlog 'ok 'nntp elmo-default-nntp-server
1495                               (std11-field-body "Newsgroups")
1496                               (std11-field-body "Message-ID")))))
1497
1498 (defun wl-draft-generate-clone-buffer (name &optional local-variables)
1499   "generate clone of current buffer named NAME."
1500   (let ((editing-buffer (current-buffer)))
1501     (save-excursion
1502       (set-buffer (generate-new-buffer name))
1503       (erase-buffer)
1504       (wl-draft-mode)
1505       (wl-draft-editor-mode)
1506       (insert-buffer editing-buffer)
1507       (message "")
1508       (while local-variables
1509         (make-local-variable (car local-variables))
1510         (set (car local-variables)
1511              (save-excursion
1512                (set-buffer editing-buffer)
1513                (symbol-value (car local-variables))))
1514         (setq local-variables (cdr local-variables)))
1515       (current-buffer))))
1516
1517 (defun wl-draft-reedit (number)
1518   (let ((draft-folder-spec (elmo-folder-get-spec wl-draft-folder))
1519         (wl-draft-reedit t)
1520         buf-name file-name change-major-mode-hook)
1521     (setq file-name (expand-file-name
1522                      (int-to-string number)
1523                      (expand-file-name
1524                       (nth 1 draft-folder-spec)
1525                       elmo-localdir-folder-path)))
1526     (unless (file-exists-p file-name)
1527       (error "File %s does not exist" file-name))
1528     (setq buf-name (find-file-noselect file-name))
1529     (if wl-draft-use-frame
1530         (switch-to-buffer-other-frame buf-name)
1531       (switch-to-buffer buf-name))
1532     (set-buffer buf-name)
1533     (if (not (string-match (regexp-quote wl-draft-folder)
1534                            (buffer-name)))
1535         (rename-buffer (concat wl-draft-folder "/" (buffer-name))))
1536     (auto-save-mode -1)
1537     (wl-draft-mode)
1538     (setq wl-sent-message-via nil)
1539     (setq wl-draft-buffer-file-name file-name)
1540     (wl-draft-config-info-operation number 'load)
1541     (goto-char (point-min))
1542     (or (re-search-forward "\n\n" nil t)
1543         (search-forward (concat mail-header-separator "\n") nil t))
1544     (if wl-on-nemacs
1545         (push-mark (point) t)
1546       (push-mark (point) t t))
1547     (write-region (point-min)(point-max) wl-draft-buffer-file-name
1548                   nil t)
1549     (wl-draft-overload-functions)
1550     (wl-draft-editor-mode)
1551     (wl-highlight-headers 'for-draft)
1552     (run-hooks 'wl-draft-reedit-hook)
1553     (goto-char (point-max))
1554     buf-name
1555     ))
1556
1557 (defmacro wl-draft-body-goto-top ()
1558   (` (progn
1559        (goto-char (point-min))
1560        (if (re-search-forward mail-header-separator nil t)
1561            (forward-char 1)
1562          (goto-char (point-max))))))
1563
1564 (defmacro wl-draft-body-goto-bottom ()
1565   (` (goto-char (point-max))))
1566
1567 (defmacro wl-draft-config-body-goto-header ()
1568   (` (progn
1569        (goto-char (point-min))
1570        (if (re-search-forward mail-header-separator nil t)
1571            (beginning-of-line)
1572          (goto-char (point-max))))))
1573
1574 (defun wl-draft-config-sub-body (content)
1575   (wl-draft-body-goto-top)
1576   (delete-region (point) (point-max))
1577   (if content (insert (eval content))))
1578
1579 (defun wl-draft-config-sub-top (content)
1580   (wl-draft-body-goto-top)
1581   (if content (insert (eval content))))
1582
1583 (defun wl-draft-config-sub-bottom (content)
1584   (wl-draft-body-goto-bottom)
1585   (if content (insert (eval content))))
1586
1587 (defun wl-draft-config-sub-header (content)
1588   (wl-draft-config-body-goto-header)
1589   (if content (insert (concat (eval content) "\n"))))
1590
1591 (defsubst wl-draft-config-sub-file (content)
1592   (let ((coding-system-for-read wl-cs-autoconv)
1593         (file (expand-file-name (eval content))))
1594     (if (file-exists-p file)
1595         (insert-file-contents file)
1596       (error "%s: no exists file" file))))
1597
1598 (defun wl-draft-config-sub-body-file (content)
1599   (wl-draft-body-goto-top)
1600   (delete-region (point) (point-max))
1601   (wl-draft-config-sub-file content))
1602
1603 (defun wl-draft-config-sub-top-file (content)
1604   (wl-draft-body-goto-top)
1605   (wl-draft-config-sub-file content))
1606
1607 (defun wl-draft-config-sub-bottom-file (content)
1608   (wl-draft-body-goto-bottom)
1609   (wl-draft-config-sub-file content))
1610
1611 (defun wl-draft-config-sub-header-file (content)
1612   (wl-draft-config-body-goto-header)
1613   (wl-draft-config-sub-file content))
1614
1615 (defun wl-draft-config-sub-template (content)
1616   (setq wl-draft-config-variables
1617         (wl-template-insert (eval content))))
1618
1619 (defun wl-draft-config-sub-x-face (content)
1620   (if (and (string-match "\\.xbm\\(\\.gz\\)?$" content)
1621            (fboundp 'x-face-insert)) ; x-face.el is installed.
1622       (x-face-insert content)
1623     (wl-draft-replace-field "X-Face" (elmo-get-file-string content t) t)))
1624
1625 (defsubst wl-draft-config-sub-func (field content)
1626   (let (func)
1627     (if (setq func (assq field wl-draft-config-sub-func-alist))
1628         (let (wl-draft-config-variables)
1629           (funcall (cdr func) content)
1630           ;; for wl-draft-config-sub-template
1631           (cons t wl-draft-config-variables)))))
1632
1633 (defsubst wl-draft-config-exec-sub (clist)
1634   (let (config local-variables)
1635     (while clist
1636       (setq config (car clist))
1637       (cond
1638        ((consp config)
1639         (let ((field (car config))
1640               (content (cdr config))
1641               ret-val)
1642           (cond
1643            ((stringp field)
1644             (wl-draft-replace-field field (eval content) t))
1645            ((setq ret-val (wl-draft-config-sub-func field content))
1646             (if (cdr ret-val) ;; for wl-draft-config-sub-template
1647                 (wl-append local-variables (cdr ret-val))))
1648            ((boundp field) ;; variable
1649             (make-local-variable field)
1650             (set field (eval content))
1651             (wl-append local-variables (list field)))
1652            (t
1653             (error "%s: not variable" field)))))
1654        ((or (functionp config)
1655             (and (symbolp config)
1656                  (fboundp config)))
1657         (funcall config))
1658        (t
1659         (error "%s: not supported type" config)))
1660       (setq clist (cdr clist)))
1661     local-variables))
1662
1663 (defun wl-draft-prepared-config-exec (&optional config-alist reply-buf)
1664   "Change headers in draft preparation time."
1665   (interactive)
1666   (unless wl-draft-reedit
1667     (let ((config-alist
1668            (or config-alist
1669                (and (boundp 'wl-draft-prepared-config-alist)
1670                     wl-draft-prepared-config-alist)     ;; For compatible.
1671                wl-draft-config-alist)))
1672       (if config-alist
1673           (wl-draft-config-exec config-alist reply-buf)))))
1674
1675 (defun wl-draft-config-exec (&optional config-alist reply-buf)
1676   "Change headers in draft sending time."
1677   (interactive)
1678   (let ((case-fold-search t)
1679         (alist (or config-alist wl-draft-config-alist))
1680         (reply-buf (or reply-buf (and (buffer-live-p wl-draft-reply-buffer)
1681                                       wl-draft-reply-buffer)))
1682         (local-variables wl-draft-config-variables)
1683         key clist found)
1684     (when (and (or (interactive-p)
1685                    wl-draft-config-exec-flag)
1686                alist)
1687       (save-excursion
1688         (catch 'done
1689           (while alist
1690             (setq key (caar alist)
1691                   clist (cdar alist))
1692             (cond
1693              ((eq key 'reply)
1694               (when (and
1695                      reply-buf
1696                      (save-excursion
1697                        (set-buffer reply-buf)
1698                        (save-restriction
1699                          (std11-narrow-to-header)
1700                          (goto-char (point-min))
1701                          (re-search-forward (car clist) nil t))))
1702                 (wl-draft-config-exec-sub (cdr clist))
1703                 (setq found t)))
1704              ((stringp key)
1705               (when (save-restriction
1706                       (std11-narrow-to-header mail-header-separator)
1707                       (goto-char (point-min))
1708                       (re-search-forward key nil t))
1709                 (wl-append local-variables
1710                            (wl-draft-config-exec-sub clist))
1711                 (setq found t)))
1712              ((eval key)
1713               (wl-append local-variables
1714                          (wl-draft-config-exec-sub clist))
1715               (setq found t)))
1716             (if (and found wl-draft-config-matchone)
1717                 (throw 'done t))
1718             (setq alist (cdr alist))))
1719         (if found
1720             (setq wl-draft-config-exec-flag nil))
1721         (run-hooks 'wl-draft-config-exec-hook)
1722         (put-text-property (point-min)(point-max) 'face nil)
1723         (wl-highlight-message (point-min)(point-max) t)
1724         (setq wl-draft-config-variables
1725               (elmo-uniq-list local-variables))))))
1726
1727 (defun wl-draft-replace-field (field content &optional add)
1728   (save-excursion
1729     (save-restriction
1730       (let ((case-fold-search t)
1731             (inhibit-read-only t) ;; added by teranisi.
1732             beg)
1733         (std11-narrow-to-header mail-header-separator)
1734         (goto-char (point-min))
1735         (if (re-search-forward (concat "^" (regexp-quote field) ":") nil t)
1736             (if content
1737                 ;; replace field
1738                 (progn
1739                   (setq beg (point))
1740                   (re-search-forward "^[^ \t]" nil 'move)
1741                   (beginning-of-line)
1742                   (skip-chars-backward "\n")
1743                   (delete-region beg (point))
1744                   (insert " " content))
1745               ;; delete field
1746               (save-excursion
1747                 (beginning-of-line)
1748                 (setq beg (point)))
1749               (re-search-forward "^[^ \t]" nil 'move)
1750               (beginning-of-line)
1751               (delete-region beg (point)))
1752           (when (and add content)
1753             ;; add field
1754             (goto-char (point-max))
1755             (insert (concat field ": " content "\n"))))))))
1756
1757 (defun wl-draft-config-info-operation (msg operation)
1758   (let* ((msgdb-dir (elmo-msgdb-expand-path wl-draft-folder))
1759          (filename
1760           (expand-file-name
1761            (format "%s-%d" wl-draft-config-save-filename msg)
1762            msgdb-dir))
1763          element alist variable)
1764     (cond
1765      ((eq operation 'save)
1766       (let ((variables (elmo-uniq-list wl-draft-config-variables)))
1767         (while (setq variable (pop variables))
1768           (when (boundp variable)
1769             (wl-append alist
1770                        (list (cons variable (eval variable))))))
1771         (elmo-object-save filename alist)))
1772      ((eq operation 'load)
1773       (setq alist (elmo-object-load filename))
1774       (while (setq element (pop alist))
1775         (set (make-local-variable (car element)) (cdr element))
1776         (wl-append wl-draft-config-variables (list (car element)))))
1777      ((eq operation 'delete)
1778       (if (file-exists-p filename)
1779           (delete-file filename))))))
1780
1781 (defun wl-draft-queue-info-operation (msg operation
1782                                           &optional add-sent-message-via)
1783   (let* ((msgdb-dir (elmo-msgdb-expand-path wl-queue-folder))
1784          (filename
1785           (expand-file-name
1786            (format "%s-%d" wl-draft-queue-save-filename msg)
1787            msgdb-dir))
1788          element alist variable)
1789     (cond
1790      ((eq operation 'save)
1791       (let ((variables (elmo-uniq-list
1792                         (append wl-draft-queue-save-variables
1793                                 wl-draft-config-variables
1794                                 (list 'wl-draft-fcc-list)))))
1795         (if add-sent-message-via
1796             (push 'wl-sent-message-via variables))
1797         (while (setq variable (pop variables))
1798           (when (boundp variable)
1799             (wl-append alist
1800                        (list (cons variable (eval variable))))))
1801         (elmo-object-save filename alist)))
1802      ((eq operation 'load)
1803       (setq alist (elmo-object-load filename))
1804       (while (setq element (pop alist))
1805         (set (make-local-variable (car element)) (cdr element))))
1806      ((eq operation 'get-sent-via)
1807       (setq alist (elmo-object-load filename))
1808       (cdr (assq 'wl-sent-message-via alist)))
1809      ((eq operation 'delete)
1810       (if (file-exists-p filename)
1811           (delete-file filename))))))
1812
1813 (defun wl-draft-queue-append (wl-sent-message-via)
1814   (if wl-draft-verbose-send
1815       (message "Queuing..."))
1816   (let ((send-buffer (current-buffer))
1817         (message-id (std11-field-body "Message-ID")))
1818     (if (elmo-append-msg wl-queue-folder
1819                          (buffer-substring (point-min) (point-max))
1820                          message-id)
1821         (progn
1822           (if message-id
1823               (elmo-dop-lock-message message-id))
1824           (wl-draft-queue-info-operation
1825            (car (elmo-max-of-folder wl-queue-folder))
1826            'save wl-sent-message-via)
1827           (wl-draft-write-sendlog 'ok 'queue nil wl-queue-folder message-id)
1828           (when wl-draft-verbose-send
1829             (setq wl-draft-verbose-msg "Queuing...")
1830             (message "Queuing...done")))
1831       (wl-draft-write-sendlog 'failed 'queue nil wl-queue-folder message-id)
1832       (error "Queuing failed"))))
1833
1834 (defun wl-draft-queue-flush ()
1835   "Flush draft queue."
1836   (interactive)
1837   (let ((msgs2 (elmo-list-folder wl-queue-folder))
1838         (i 0)
1839         (performed 0)
1840         (wl-draft-queue-flushing t)
1841         msgs failure len buffer msgid sent-via)
1842     ;; get plugged send message
1843     (while msgs2
1844       (setq sent-via (wl-draft-queue-info-operation (car msgs2) 'get-sent-via))
1845       (catch 'found
1846         (while sent-via
1847           (when (and (eq (nth 1 (car sent-via)) 'unplugged)
1848                      (elmo-plugged-p
1849                       (car (nth 2 (car sent-via)))
1850                       (cdr (nth 2 (car sent-via)))))
1851             (wl-append msgs (list (car msgs2)))
1852             (throw 'found t))
1853           (setq sent-via (cdr sent-via))))
1854       (setq msgs2 (cdr msgs2)))
1855     (when (> (setq len (length msgs)) 0)
1856       (if (elmo-y-or-n-p (format
1857                           "%d message(s) are in the sending queue. Send now?"
1858                           len)
1859                          (not elmo-dop-flush-confirm) t)
1860           (progn
1861             (save-excursion
1862               (setq buffer (get-buffer-create " *wl-draft-queue-flush*"))
1863               (set-buffer buffer)
1864               (while msgs
1865                 ;; reset buffer local variables
1866                 (kill-all-local-variables)
1867                 (erase-buffer)
1868                 (setq i (+ 1 i)
1869                       failure nil)
1870                 (setq wl-sent-message-via nil)
1871                 (wl-draft-queue-info-operation (car msgs) 'load)
1872                 (elmo-read-msg-no-cache wl-queue-folder (car msgs)
1873                                         (current-buffer))
1874                 (condition-case err
1875                     (setq failure (funcall
1876                                    wl-draft-queue-flush-send-func
1877                                    (format "Sending (%d/%d)..." i len)))
1878 ;;;               (wl-draft-raw-send nil nil
1879 ;;;                                  (format "Sending (%d/%d)..." i len))
1880                   (error
1881                    (elmo-display-error err t)
1882                    (setq failure t))
1883                   (quit
1884                    (setq failure t)))
1885                 (unless failure
1886                   (elmo-delete-msgs wl-queue-folder (cons (car msgs) nil))
1887                   (wl-draft-queue-info-operation (car msgs) 'delete)
1888                   (elmo-dop-unlock-message (std11-field-body "Message-ID"))
1889                   (setq performed (+ 1 performed)))
1890                 (setq msgs (cdr msgs)))
1891               (kill-buffer buffer)
1892               (message "%d message(s) are sent." performed)))
1893         (message "%d message(s) are remained to be sent." len))
1894       len)))
1895
1896 (defun wl-jump-to-draft-buffer (&optional arg)
1897   "Jump to the draft if exists."
1898   (interactive "P")
1899   (if arg
1900       (wl-jump-to-draft-folder)
1901     (let ((bufs (buffer-list))
1902           (draft-regexp (concat
1903                          "^" (regexp-quote
1904                               (expand-file-name
1905                                (nth 1 (elmo-folder-get-spec wl-draft-folder))
1906                                (expand-file-name
1907                                 elmo-localdir-folder-path)))))
1908           buf draft-bufs)
1909       (while bufs
1910         (if (and
1911              (setq buf (buffer-file-name (car bufs)))
1912              (string-match draft-regexp buf))
1913             (setq draft-bufs (cons (buffer-name (car bufs)) draft-bufs)))
1914         (setq bufs (cdr bufs)))
1915       (cond
1916        ((null draft-bufs)
1917         (message "No draft buffer exist."))
1918        (t
1919         (setq draft-bufs
1920               (sort draft-bufs (function (lambda (a b) (not (string< a b))))))
1921         (if (setq buf (cdr (member (buffer-name) draft-bufs)))
1922             (setq buf (car buf))
1923           (setq buf (car draft-bufs)))
1924         (switch-to-buffer buf))))))
1925
1926 (defun wl-jump-to-draft-folder ()
1927   (let ((msgs (reverse (elmo-list-folder wl-draft-folder)))
1928         (mybuf (buffer-name))
1929         msg buf)
1930     (if (not msgs)
1931         (message "No draft message exist.")
1932       (if (string-match (concat "^" wl-draft-folder "/") mybuf)
1933           (setq msg (cadr (memq
1934                            (string-to-int (substring mybuf (match-end 0)))
1935                            msgs))))
1936       (or msg (setq msg (car msgs)))
1937       (if (setq buf (get-buffer (format "%s/%d" wl-draft-folder msg)))
1938           (switch-to-buffer buf)
1939         (wl-draft-reedit msg)))))
1940
1941 (defun wl-draft-highlight-and-recenter (&optional n)
1942   (interactive "P")
1943   (if wl-highlight-body-too
1944       (let ((beg (point-min))
1945             (end (point-max)))
1946         (put-text-property beg end 'face nil)
1947         (wl-highlight-message beg end t)))
1948   (recenter n))
1949
1950 ;;;; user-agent support by Sen Nagata
1951
1952 ;; this appears to be necessarily global...
1953 (defvar wl-user-agent-compose-p nil)
1954 (defvar wl-user-agent-headers-and-body-alist nil)
1955
1956 ;; this should be a generic function for mail-mode -- i wish there was
1957 ;; something like it in sendmail.el
1958 (defun wl-user-agent-insert-header (header-name header-value)
1959   "Insert HEADER-NAME w/ value HEADER-VALUE into a message."
1960   ;; it seems like overriding existing headers is acceptable -- should
1961   ;; we provide an option?
1962
1963   ;; plan was: unfold header (might be folded), remove existing value, insert
1964   ;;           new value
1965   ;; wl doesn't seem to fold header lines yet anyway :-)
1966
1967   (let ((kill-whole-line t)
1968         end-of-line)
1969     (mail-position-on-field (capitalize header-name))
1970     (setq end-of-line (point))
1971     (beginning-of-line)
1972     (re-search-forward ":" end-of-line)
1973     (insert (concat " " header-value "\n"))
1974     (kill-line)))
1975
1976 ;; this should be a generic function for mail-mode -- i wish there was
1977 ;; something like it in sendmail.el
1978 ;;
1979 ;; ** haven't dealt w/ case where the body is already set **
1980 (defun wl-user-agent-insert-body (body-text)
1981   "Insert a body of text, BODY-TEXT, into a message."
1982   ;; code defensively... :-P
1983   (goto-char (point-min))
1984   (search-forward mail-header-separator)
1985   (forward-line 1)
1986   (insert body-text))
1987
1988 ;;;###autoload
1989 (defun wl-user-agent-compose (&optional to subject other-headers continue
1990                                         switch-function yank-action
1991                                         send-actions)
1992   "Support the `compose-mail' interface for wl.
1993 Only support for TO, SUBJECT, and OTHER-HEADERS has been implemented.
1994 Support for CONTINUE, YANK-ACTION, and SEND-ACTIONS has not
1995 been implemented yet.  Partial support for SWITCH-FUNCTION now supported."
1996
1997   (unless (featurep 'wl)
1998     (require 'wl))
1999   ;; protect these -- to and subject get bound at some point, so it looks
2000   ;; to be necessary to protect the values used w/in
2001   (let ((wl-user-agent-headers-and-body-alist other-headers)
2002         (wl-draft-use-frame (eq switch-function 'switch-to-buffer-other-frame))
2003         (wl-draft-reply-buffer-style 'split))
2004     (when (eq switch-function 'switch-to-buffer-other-window)
2005       (when (one-window-p t)
2006         (if (window-minibuffer-p) (other-window 1))
2007         (split-window))
2008       (other-window 1))
2009     (if to
2010         (if (wl-string-match-assoc "to" wl-user-agent-headers-and-body-alist
2011                                    'ignore-case)
2012             (setcdr
2013              (wl-string-match-assoc "to" wl-user-agent-headers-and-body-alist
2014                                     'ignore-case)
2015              to)
2016           (setq wl-user-agent-headers-and-body-alist
2017                 (cons (cons "to" to)
2018                       wl-user-agent-headers-and-body-alist))))
2019     (if subject
2020         (if (wl-string-match-assoc "subject"
2021                                    wl-user-agent-headers-and-body-alist
2022                                    'ignore-case)
2023             (setcdr
2024              (wl-string-match-assoc "subject"
2025                                     wl-user-agent-headers-and-body-alist
2026                                     'ignore-case)
2027              subject)
2028           (setq wl-user-agent-headers-and-body-alist
2029                 (cons (cons "subject" subject)
2030                       wl-user-agent-headers-and-body-alist))))
2031     ;; i think this is what we want to use...
2032     (unwind-protect
2033         (progn
2034           ;; tell the hook-function to do its stuff
2035           (setq wl-user-agent-compose-p t)
2036           ;; because to get the hooks working, wl-draft has to think it has
2037           ;; been called interactively
2038           (call-interactively 'wl-draft))
2039       (setq wl-user-agent-compose-p nil))))
2040
2041 (defun wl-user-agent-compose-internal ()
2042   "Manipulate headers and/or a body of a draft message."
2043   ;; being called from wl-user-agent-compose?
2044   (if wl-user-agent-compose-p
2045       (progn
2046         ;; insert headers
2047         (let ((headers wl-user-agent-headers-and-body-alist)
2048               (case-fold-search t))
2049           (while headers
2050             ;; skip body
2051             (if (not (string-match "^body$" (car (car headers))))
2052                 (wl-user-agent-insert-header
2053                  (car (car headers)) (cdr (car headers)))
2054               t)
2055             (setq headers (cdr headers))))
2056         ;; highlight headers (from wl-draft in wl-draft.el)
2057         (wl-highlight-headers 'for-draft)
2058         ;; insert body
2059         (if (wl-string-match-assoc "body" wl-user-agent-headers-and-body-alist
2060                                    'ignore-case)
2061             (wl-user-agent-insert-body
2062              (cdr (wl-string-match-assoc
2063                    "body"
2064                    wl-user-agent-headers-and-body-alist 'ignore-case)))))
2065     t))
2066
2067 (require 'product)
2068 (product-provide (provide 'wl-draft) (require 'wl-version))
2069
2070 ;;; wl-draft.el ends here