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
  45 (eval-when-compile
  46   (require 'static)
  47   (require 'elmo-pop3)
  48   (defalias-maybe 'x-face-insert 'ignore)
  49   (defalias-maybe 'x-face-insert-version-header 'ignore)
  50   (defalias-maybe 'wl-init 'ignore)
  51   (defalias-maybe 'wl-draft-mode 'ignore))
  52
  53 (eval-and-compile
  54   (autoload 'wl-addrmgr "wl-addrmgr"))
  55
  56 (autoload 'open-ssl-stream "ssl")
  57
  58 (defvar wl-draft-buffer-message-number 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-function 'wl-draft-dispatch-message)
  71 (defvar wl-sent-message-via nil)
  72 (defvar wl-sent-message-modified nil)
  73 (defvar wl-sent-message-queued nil)
  74 (defvar wl-draft-fcc-list nil)
  75 (defvar wl-draft-reedit nil)
  76 (defvar wl-draft-reply-buffer nil)
  77 (defvar wl-draft-forward nil)
  78 (defvar wl-draft-doing-mime-bcc nil)
  79
  80 (defvar wl-draft-parent-folder nil
  81   "Folder name of the summary in which current draft is invoked.
  82 This variable is local in each draft buffer.
  83 You can refer its value in `wl-draft-config-alist'.
  84
  85 e.g.
  86 \(setq wl-draft-config-alist
  87       '(((string-match \".*@domain1$\" wl-draft-parent-folder)
  88          (\"From\" . \"user@domain1\"))
  89         ((string-match \".*@domain2$\" wl-draft-parent-folder)
  90          (\"From\" . \"user@domain2\"))))")
  91
  92 (defvar wl-draft-parent-number nil)
  93
  94 (defconst wl-draft-reply-saved-variables
  95   '(wl-draft-parent-folder
  96     wl-draft-parent-number))
  97
  98 (defvar wl-draft-config-sub-func-alist
  99   '((body               . wl-draft-config-sub-body)
 100     (top                . wl-draft-config-sub-top)
 101     (bottom             . wl-draft-config-sub-bottom)
 102     (header             . wl-draft-config-sub-header)
 103     (header-top         . wl-draft-config-sub-header-top)
 104     (header-bottom      . wl-draft-config-sub-header)
 105     (part-top           . wl-draft-config-sub-part-top)
 106     (part-bottom        . wl-draft-config-sub-part-bottom)
 107     (body-file          . wl-draft-config-sub-body-file)
 108     (top-file           . wl-draft-config-sub-top-file)
 109     (bottom-file        . wl-draft-config-sub-bottom-file)
 110     (header-file        . wl-draft-config-sub-header-file)
 111     (template           . wl-draft-config-sub-template)
 112     (x-face             . wl-draft-config-sub-x-face)))
 113
 114 (make-variable-buffer-local 'wl-draft-buffer-message-number)
 115 (make-variable-buffer-local 'wl-draft-buffer-cur-summary-buffer)
 116 (make-variable-buffer-local 'wl-draft-config-variables)
 117 (make-variable-buffer-local 'wl-draft-config-exec-flag)
 118 (make-variable-buffer-local 'wl-sent-message-via)
 119 (make-variable-buffer-local 'wl-sent-message-queued)
 120 (make-variable-buffer-local 'wl-draft-fcc-list)
 121 (make-variable-buffer-local 'wl-draft-reply-buffer)
 122 (make-variable-buffer-local 'wl-draft-parent-folder)
 123 (make-variable-buffer-local 'wl-draft-parent-number)
 124
 125 (defvar wl-draft-folder-internal nil
 126   "Internal variable for caching `opened' draft folder.")
 127
 128 (defsubst wl-smtp-password-key (user mechanism server)
 129   (format "SMTP:%s/%s@%s"
 130           user mechanism server))
 131
 132 (defmacro wl-smtp-extension-bind (&rest body)
 133   (` (let* ((smtp-sasl-mechanisms
 134              (if wl-smtp-authenticate-type
 135                  (mapcar 'upcase
 136                          (if (listp wl-smtp-authenticate-type)
 137                              wl-smtp-authenticate-type
 138                            (list wl-smtp-authenticate-type)))))
 139             (smtp-use-sasl (and smtp-sasl-mechanisms t))
 140             (smtp-use-starttls (eq wl-smtp-connection-type 'starttls))
 141             (smtp-open-connection-function
 142              (if (eq wl-smtp-connection-type 'ssl)
 143                  #'open-ssl-stream
 144                smtp-open-connection-function))
 145             (smtp-end-of-line
 146              (if (eq wl-smtp-connection-type 'ssl)
 147                  "\n"
 148                smtp-end-of-line))
 149             smtp-sasl-user-name smtp-sasl-properties sasl-read-passphrase)
 150        (if (and (string= (car smtp-sasl-mechanisms) "DIGEST-MD5")
 151                 ;; sendmail bug?
 152                 (string-match "^\\([^@]*\\)@\\([^@]*\\)"
 153                               wl-smtp-posting-user))
 154            (setq smtp-sasl-user-name (match-string 1 wl-smtp-posting-user)
 155                  smtp-sasl-properties (list 'realm
 156                                             (match-string 2 wl-smtp-posting-user)))
 157          (setq smtp-sasl-user-name wl-smtp-posting-user
 158                smtp-sasl-properties nil))
 159        (setq sasl-read-passphrase
 160              (function
 161               (lambda (prompt)
 162                 (elmo-get-passwd
 163                  (wl-smtp-password-key
 164                   smtp-sasl-user-name
 165                   (car smtp-sasl-mechanisms)
 166                   smtp-server)))))
 167        (,@ body))))
 168
 169 (defun wl-draft-insert-date-field ()
 170   "Insert Date field."
 171   (insert "Date: " (wl-make-date-string) "\n"))
 172
 173 (defun wl-draft-insert-from-field ()
 174   "Insert From field."
 175   ;; Put the "From:" field in unless for some odd reason
 176   ;; they put one in themselves.
 177   (let (from)
 178     (condition-case err
 179         (setq from (wl-draft-eword-encode-address-list wl-from))
 180       (error (error "Please look at `wl-from' again")))
 181     (insert "From: " from "\n")))
 182
 183 (defun wl-draft-insert-x-face-field ()
 184   "Insert X-Face header."
 185   (interactive)
 186   (if (not (file-exists-p wl-x-face-file))
 187       (error "File %s does not exist" wl-x-face-file)
 188     (goto-char (point-min))
 189     (search-forward mail-header-separator nil t)
 190     (beginning-of-line)
 191     (wl-draft-insert-x-face-field-here)
 192     (run-hooks 'wl-draft-insert-x-face-field-hook))) ; highlight it if you want.
 193
 194 (defun wl-draft-insert-x-face-field-here ()
 195   "Insert X-Face field at point."
 196   (let ((x-face-string (elmo-get-file-string wl-x-face-file)))
 197     (when (string-match "^\\(X-Face:\\)?[ \t\n]*" x-face-string)
 198       (setq x-face-string (substring x-face-string (match-end 0))))
 199     (insert "X-Face: " x-face-string))
 200   (when (not (= (preceding-char) ?\n))  ; for chomped (choped) x-face-string
 201     (insert ?\n))
 202   ;; Insert X-Face-Version: field
 203   (when (and (fboundp 'x-face-insert-version-header)
 204              (boundp 'x-face-add-x-face-version-header)
 205              x-face-add-x-face-version-header)
 206     (x-face-insert-version-header)))
 207
 208 (defun wl-draft-setup ()
 209   (let ((field wl-draft-fields)
 210         cl)
 211     (while field
 212       (setq cl (append cl
 213                        (list (cons (concat (car field) " ")
 214                                    (concat (car field) " ")))))
 215       (setq field (cdr field)))
 216     (setq cl
 217           (cons (cons (concat wl-draft-mime-bcc-field-name  ": ")
 218                       (concat wl-draft-mime-bcc-field-name  ": "))
 219                 cl))
 220     (setq wl-draft-field-completion-list cl)
 221     (setq wl-address-complete-header-regexp
 222           (wl-regexp-opt
 223            (append wl-address-complete-header-list
 224                    (list (concat wl-draft-mime-bcc-field-name  ":")))))))
 225
 226 (defun wl-draft-make-mail-followup-to (recipients)
 227   (if (elmo-list-member
 228        (or wl-user-mail-address-list
 229            (list (wl-address-header-extract-address wl-from)))
 230        recipients)
 231       (let ((rlist (elmo-list-delete
 232                     (or wl-user-mail-address-list
 233                         (list (wl-address-header-extract-address wl-from)))
 234                     recipients
 235                     (lambda (elem list)
 236                       (elmo-delete-if
 237                        (lambda (item) (string= (downcase elem)
 238                                                (downcase item)))
 239                        list)))))
 240         (if (elmo-list-member rlist (mapcar 'downcase
 241                                             wl-subscribed-mailing-list))
 242             rlist
 243           (append rlist (list (wl-address-header-extract-address
 244                                wl-from)))))
 245     recipients))
 246
 247 (defun wl-draft-delete-myself-from-cc (to cc)
 248   (let ((myself (or wl-user-mail-address-list
 249                     (list (wl-address-header-extract-address wl-from)))))
 250     (cond (wl-draft-always-delete-myself ; always-delete option
 251            (elmo-list-delete myself cc
 252                              (lambda (elem list)
 253                                (elmo-delete-if
 254                                 (lambda (item) (string= (downcase elem)
 255                                                         (downcase item)))
 256                                 list))))
 257           ((elmo-list-member (append to cc) ; subscribed mailing-list
 258                              (mapcar 'downcase wl-subscribed-mailing-list))
 259            (elmo-list-delete myself cc
 260                              (lambda (elem list)
 261                                (elmo-delete-if
 262                                 (lambda (item) (string= (downcase elem)
 263                                                         (downcase item)))
 264                                 list))))
 265           (t cc))))
 266
 267 (defun wl-draft-forward (original-subject summary-buf)
 268   (let (references parent-folder)
 269     (with-current-buffer summary-buf
 270       (setq parent-folder (wl-summary-buffer-folder-name)))
 271     (with-current-buffer (wl-message-get-original-buffer)
 272       (setq references (nconc
 273                         (std11-field-bodies '("References" "In-Reply-To"))
 274                         (list (std11-field-body "Message-Id"))))
 275       (setq references (delq nil references)
 276             references (mapconcat 'identity references " ")
 277             references (wl-draft-parse-msg-id-list-string references)
 278             references (wl-delete-duplicates references)
 279             references (when references
 280                          (mapconcat 'identity references "\n\t"))))
 281     (and wl-draft-use-frame
 282          (get-buffer-window summary-buf)
 283          (select-window (get-buffer-window summary-buf)))
 284     (wl-draft (list (cons 'To "")
 285                     (cons 'Subject
 286                           (concat wl-forward-subject-prefix original-subject))
 287                     (cons 'References references))
 288               nil nil nil nil parent-folder))
 289   (goto-char (point-max))
 290   (wl-draft-insert-message)
 291   (mail-position-on-field "To"))
 292
 293 (defun wl-draft-strip-subject-re (subject)
 294   "Remove \"Re:\" from SUBJECT string. Shamelessly copied from Gnus."
 295   (if (string-match wl-subject-prefix-regexp subject)
 296       (substring subject (match-end 0))
 297     subject))
 298
 299 (defun wl-draft-self-reply-p ()
 300   "Return t when From address in the current message is user's self one or not."
 301   (wl-address-user-mail-address-p (or (elmo-field-body "From") "")))
 302
 303 (defun wl-draft-reply (buf with-arg summary-buf &optional number)
 304   "Reply to BUF buffer message.
 305 Reply to author if WITH-ARG is non-nil."
 306 ;;;(save-excursion
 307   (let (r-list
 308         to mail-followup-to cc subject in-reply-to references newsgroups
 309         to-alist cc-alist decoder parent-folder)
 310     (when (buffer-live-p summary-buf)
 311       (with-current-buffer summary-buf
 312         (setq parent-folder (wl-summary-buffer-folder-name))))
 313     (set-buffer (or buf mime-mother-buffer))
 314     (setq r-list (if with-arg wl-draft-reply-with-argument-list
 315                    wl-draft-reply-without-argument-list))
 316     (catch 'done
 317       (while r-list
 318         (when (let ((condition (car (car r-list))))
 319                 (cond ((stringp condition)
 320                        (std11-field-body condition))
 321                       ((listp condition)
 322                        (catch 'done
 323                          (while condition
 324                            (cond
 325                             ((stringp (car condition))
 326                              (or (std11-field-body (car condition))
 327                                  (throw 'done nil)))
 328                             ((symbolp (car condition))
 329                              (or (funcall (car condition))
 330                                  (throw 'done nil)))
 331                             (t
 332                              (debug)))
 333                            (setq condition (cdr condition)))
 334                          t))
 335                       ((symbolp condition)
 336                        (funcall condition))))
 337           (let ((r-to-list (nth 0 (cdr (car r-list))))
 338                 (r-cc-list (nth 1 (cdr (car r-list))))
 339                 (r-ng-list (nth 2 (cdr (car r-list)))))
 340             (when (and (member "Followup-To" r-ng-list)
 341                        (string= (std11-field-body "Followup-To") "poster"))
 342               (setq r-to-list (cons "From" r-to-list))
 343               (setq r-ng-list (delete "Followup-To"
 344                                       (copy-sequence r-ng-list))))
 345             (if (and r-to-list (symbolp r-to-list))
 346                 (setq to (wl-concat-list (funcall r-to-list) ","))
 347               (setq to (wl-concat-list (cons to
 348                                              (elmo-multiple-fields-body-list
 349                                               r-to-list))
 350                                        ",")))
 351             (if (and r-cc-list (symbolp r-cc-list))
 352                 (setq cc (wl-concat-list (funcall r-cc-list) ","))
 353               (setq cc (wl-concat-list (cons cc
 354                                              (elmo-multiple-fields-body-list
 355                                               r-cc-list))
 356                                        ",")))
 357             (if (and r-ng-list (symbolp r-ng-list))
 358                 (setq newsgroups (wl-concat-list (funcall r-ng-list) ","))
 359               (setq newsgroups (wl-concat-list (cons newsgroups
 360                                                      (std11-field-bodies
 361                                                       r-ng-list))
 362                                                ","))))
 363           (throw 'done nil))
 364         (setq r-list (cdr r-list)))
 365       (error "No match field: check your `wl-draft-reply-%s-argument-list'"
 366              (if with-arg "with" "without")))
 367     (setq subject (std11-field-body "Subject"))
 368     (setq to (wl-parse-addresses to)
 369           cc (wl-parse-addresses cc))
 370     (with-temp-buffer                   ; to keep raw buffer unibyte.
 371       (elmo-set-buffer-multibyte default-enable-multibyte-characters)
 372       (setq decoder (mime-find-field-decoder 'Subject 'plain))
 373       (setq subject (if (and subject decoder)
 374                         (funcall decoder subject) subject))
 375       (setq to-alist
 376             (mapcar
 377              (lambda (addr)
 378                (setq decoder (mime-find-field-decoder 'To 'plain))
 379                (cons (nth 1 (std11-extract-address-components addr))
 380                      (if decoder (funcall decoder addr) addr)))
 381              to))
 382       (setq cc-alist
 383             (mapcar
 384              (lambda (addr)
 385                (setq decoder (mime-find-field-decoder 'Cc 'plain))
 386                (cons (nth 1 (std11-extract-address-components addr))
 387                      (if decoder (funcall decoder addr) addr)))
 388              cc)))
 389     (and wl-reply-subject-prefix
 390          (setq subject (concat wl-reply-subject-prefix
 391                                (wl-draft-strip-subject-re
 392                                 (or subject "")))))
 393     (setq in-reply-to (std11-field-body "Message-Id"))
 394     (setq references (nconc
 395                       (std11-field-bodies '("References" "In-Reply-To"))
 396                       (list in-reply-to)))
 397     (setq to (delq nil (mapcar 'car to-alist)))
 398     (setq cc (delq nil (mapcar 'car cc-alist)))
 399     ;; if subscribed mailing list is contained in cc or to
 400     ;; and myself is contained in cc,
 401     ;; delete myself from cc.
 402     (setq cc (wl-draft-delete-myself-from-cc to cc))
 403     (when wl-insert-mail-followup-to
 404       (setq mail-followup-to
 405             (wl-draft-make-mail-followup-to (append to cc)))
 406       (setq mail-followup-to (wl-delete-duplicates mail-followup-to nil t)))
 407     (with-temp-buffer                   ; to keep raw buffer unibyte.
 408       (elmo-set-buffer-multibyte default-enable-multibyte-characters)
 409       (setq newsgroups (wl-parse newsgroups
 410                                  "[ \t\f\r\n,]*\\([^ \t\f\r\n,]+\\)")
 411             newsgroups (wl-delete-duplicates newsgroups)
 412             newsgroups
 413             (if newsgroups
 414                 (mapconcat
 415                  (lambda (grp)
 416                    (setq decoder (mime-find-field-decoder 'Newsgroups 'plain))
 417                    (if decoder (funcall decoder grp) grp))
 418                  newsgroups ","))))
 419     (setq to (wl-delete-duplicates to nil t))
 420     (setq cc (wl-delete-duplicates
 421               (append (wl-delete-duplicates cc nil t)
 422                       to (copy-sequence to))
 423               t t))
 424     (and to (setq to (mapconcat
 425                       '(lambda (addr)
 426                          (if wl-draft-reply-use-address-with-full-name
 427                              (or (cdr (assoc addr to-alist)) addr)
 428                            addr))
 429                       to ",\n\t")))
 430     (and cc (setq cc (mapconcat
 431                       '(lambda (addr)
 432                          (if wl-draft-reply-use-address-with-full-name
 433                              (or (cdr (assoc addr cc-alist)) addr)
 434                            addr))
 435                       cc ",\n\t")))
 436     (and mail-followup-to
 437          (setq mail-followup-to
 438                (mapconcat
 439                 '(lambda (addr)
 440                    (if wl-draft-reply-use-address-with-full-name
 441                        (or (cdr (assoc addr (append to-alist cc-alist))) addr)
 442                      addr))
 443                 mail-followup-to ",\n\t")))
 444     (and (null to) (setq to cc cc nil))
 445     (setq references (delq nil references)
 446           references (mapconcat 'identity references " ")
 447           references (wl-draft-parse-msg-id-list-string references)
 448           references (wl-delete-duplicates references)
 449           references (if references
 450                          (mapconcat 'identity references "\n\t")))
 451     (and wl-draft-use-frame
 452          (get-buffer-window summary-buf)
 453          (select-window (get-buffer-window summary-buf)))
 454     (wl-draft (list (cons 'To to)
 455                     (cons 'Cc cc)
 456                     (cons 'Newsgroups newsgroups)
 457                     (cons 'Subject subject)
 458                     (cons 'In-Reply-To in-reply-to)
 459                     (cons 'References references)
 460                     (cons 'Mail-Followup-To mail-followup-to))
 461               nil nil nil nil parent-folder)
 462     (setq wl-draft-parent-number number)
 463     (setq wl-draft-reply-buffer buf)
 464     (setq wl-draft-config-variables
 465           (append wl-draft-reply-saved-variables
 466                   wl-draft-config-variables)))
 467   (run-hooks 'wl-reply-hook))
 468
 469 (defun wl-draft-reply-position (position)
 470   (cond ((eq position 'body)
 471          (wl-draft-body-goto-top))
 472         ((eq position 'bottom)
 473          (wl-draft-body-goto-bottom))
 474         ((eq position 'top)
 475          (goto-char (point-min)))
 476         ((and (stringp position)
 477               (std11-field-body position))
 478          (progn (mail-position-on-field position)
 479                 (wl-draft-beginning-of-line)))
 480         ((listp position)
 481          (while (car position)
 482            (wl-draft-reply-position (car position))
 483            (setq position (cdr position))))))
 484
 485 (defun wl-draft-add-references ()
 486   (wl-draft-add-in-reply-to "References"))
 487
 488 (defun wl-draft-add-in-reply-to (&optional alt-field)
 489   (let* ((mes-id (save-excursion
 490                    (set-buffer mail-reply-buffer)
 491                    (std11-field-body "message-id")))
 492          (field (or alt-field "In-Reply-To"))
 493          (ref (std11-field-body field))
 494          (ref-list nil) (st nil))
 495     (when (and mes-id ref)
 496       (while (string-match "<[^>]+>" ref st)
 497         (setq ref-list
 498               (cons (substring ref (match-beginning 0) (setq st (match-end 0)))
 499                     ref-list)))
 500       (when (and ref-list
 501                  (member mes-id ref-list))
 502         (setq mes-id nil)))
 503     (when mes-id
 504       (save-excursion
 505         (when (mail-position-on-field field)
 506           (forward-line)
 507           (while (looking-at "^[ \t]")
 508             (forward-line))
 509           (setq mes-id (concat "\t" mes-id "\n")))
 510         (insert mes-id))
 511       t)))
 512
 513 (defun wl-draft-yank-from-mail-reply-buffer (decode-it
 514                                              &optional ignored-fields)
 515   (interactive)
 516   (save-restriction
 517     (narrow-to-region (point)(point))
 518     (insert
 519      (string-as-multibyte
 520       (with-current-buffer mail-reply-buffer
 521         (when decode-it
 522           (decode-mime-charset-region (point-min) (point-max)
 523                                       wl-mime-charset))
 524         (buffer-substring-no-properties
 525          (point-min) (point-max)))))
 526     (when ignored-fields
 527       (goto-char (point-min))
 528       (wl-draft-delete-fields ignored-fields))
 529     (goto-char (point-max))
 530     (push-mark (point) nil t)
 531     (goto-char (point-min)))
 532   (let ((beg (point)))
 533     (cond (mail-citation-hook (run-hooks 'mail-citation-hook))
 534           (mail-yank-hooks (run-hooks 'mail-yank-hooks))
 535           (wl-draft-cite-function (funcall wl-draft-cite-function))) ; default cite
 536     (run-hooks 'wl-draft-cited-hook)
 537     (when (if wl-draft-add-references
 538               (wl-draft-add-references)
 539             (if wl-draft-add-in-reply-to
 540                 (wl-draft-add-in-reply-to)))
 541       (wl-highlight-headers 'for-draft)) ; highlight when added References:
 542     (when wl-highlight-body-too
 543       (wl-highlight-body-region beg (point-max)))))
 544
 545 (defun wl-message-news-p ()
 546   "If exist valid Newsgroups field, return non-nil."
 547   (std11-field-body "Newsgroups"))
 548
 549 (defun wl-message-field-exists-p (field)
 550   "If FIELD exist and FIELD value is not empty, return non-nil."
 551   (let ((value (std11-field-body field)))
 552     (and value
 553          (not (string= value "")))))
 554
 555 (defun wl-message-mail-p ()
 556   "If exist To, Cc or Bcc field, return non-nil."
 557   (or (wl-message-field-exists-p "To")
 558       (wl-message-field-exists-p "Resent-to")
 559       (wl-message-field-exists-p "Cc")
 560       (wl-message-field-exists-p "Bcc")
 561       (wl-message-field-exists-p wl-draft-mime-bcc-field-name)
 562 ;;; This may be needed..
 563 ;;;   (wl-message-field-exists-p "Fcc")
 564       ))
 565
 566 (defun wl-draft-edit-string (string)
 567   (let ((cur-buf (current-buffer))
 568         (tmp-buf (get-buffer-create " *wl-draft-edit-string*"))
 569         to subject in-reply-to cc references newsgroups mail-followup-to
 570         content-type content-transfer-encoding from
 571         body-beg)
 572     (set-buffer tmp-buf)
 573     (erase-buffer)
 574     (insert string)
 575     (setq to (std11-field-body "To"))
 576     (setq to (and to
 577                   (eword-decode-string
 578                    (decode-mime-charset-string
 579                     to
 580                     wl-mime-charset))))
 581     (setq subject (std11-field-body "Subject"))
 582     (setq subject (and subject
 583                        (eword-decode-string
 584                         (decode-mime-charset-string
 585                          subject
 586                          wl-mime-charset))))
 587     (setq from (std11-field-body "From")
 588           from (and from
 589                     (eword-decode-string
 590                      (decode-mime-charset-string
 591                       from
 592                       wl-mime-charset))))
 593     (setq in-reply-to (std11-field-body "In-Reply-To"))
 594     (setq cc (std11-field-body "Cc"))
 595     (setq cc (and cc
 596                   (eword-decode-string
 597                    (decode-mime-charset-string
 598                     cc
 599                     wl-mime-charset))))
 600     (setq references (std11-field-body "References"))
 601     (setq newsgroups (std11-field-body "Newsgroups"))
 602     (setq mail-followup-to (std11-field-body "Mail-Followup-To"))
 603     (setq content-type (std11-field-body "Content-Type"))
 604     (setq content-transfer-encoding (std11-field-body "Content-Transfer-Encoding"))
 605     (goto-char (point-min))
 606     (or (re-search-forward "\n\n" nil t)
 607         (search-forward (concat mail-header-separator "\n") nil t))
 608     (unwind-protect
 609         (set-buffer
 610          (wl-draft (list
 611                     (cons 'From
 612                           (if (member
 613                                (nth 1 (std11-extract-address-components from))
 614                                wl-user-mail-address-list)
 615                               from))
 616                     (cons 'To to)
 617                     (cons 'Cc cc)
 618                     (cons 'Subject subject)
 619                     (cons 'Newsgroups newsgroups)
 620                     (cons 'Mail-Followup-To mail-followup-to)
 621                     (cons 'In-Reply-To in-reply-to)
 622                     (cons 'References references))
 623                    content-type content-transfer-encoding
 624                    (buffer-substring (point) (point-max))
 625                    'edit-again))
 626       (kill-buffer tmp-buf))
 627     ;; Set cursor point to the top.
 628     (goto-char (point-min))
 629     (search-forward (concat mail-header-separator "\n") nil t)
 630     (run-hooks 'wl-draft-reedit-hook)
 631     (and to (mail-position-on-field "To"))))
 632
 633 (defun wl-draft-insert-current-message (dummy)
 634   (interactive)
 635   (let (original-buffer
 636         mail-reply-buffer
 637         mail-citation-hook mail-yank-hooks
 638         wl-draft-add-references wl-draft-add-in-reply-to
 639         wl-draft-cite-function)
 640     (if (and wl-draft-buffer-cur-summary-buffer
 641              (with-current-buffer wl-draft-buffer-cur-summary-buffer
 642                (and wl-message-buffer
 643                     (with-current-buffer wl-message-buffer
 644                       (setq original-buffer (wl-message-get-original-buffer))
 645                       (not (zerop (with-current-buffer original-buffer
 646                                     (buffer-size))))))))
 647         (progn
 648           (setq mail-reply-buffer original-buffer)
 649           (wl-draft-yank-from-mail-reply-buffer
 650            nil
 651            wl-ignored-forwarded-headers))
 652       (when (string= (mime-make-tag "message" "rfc822")
 653                      (buffer-substring-no-properties (point-at-bol 0)(point-at-eol 0)))
 654         (delete-region (point-at-bol 0) (1+ (point-at-eol 0))))
 655       (error "No current message"))))
 656
 657 (defun wl-draft-insert-get-message (dummy)
 658   (let ((fld (completing-read
 659               "Folder name: "
 660               (if (memq 'read-folder wl-use-folder-petname)
 661                   (wl-folder-get-entity-with-petname)
 662                 wl-folder-entity-hashtb)
 663               nil nil wl-default-spec
 664               'wl-read-folder-history))
 665         (number (call-interactively
 666                  (function (lambda (num)
 667                              (interactive "nNumber: ")
 668                              num))))
 669         (mail-reply-buffer (get-buffer-create "*wl-draft-insert-get-message*"))
 670         mail-citation-hook mail-yank-hooks
 671         wl-draft-cite-function)
 672     (unwind-protect
 673         (progn
 674           (elmo-message-fetch (wl-folder-get-elmo-folder fld)
 675                               number
 676                               ;; No cache.
 677                               (elmo-make-fetch-strategy 'entire)
 678                               nil mail-reply-buffer)
 679           (wl-draft-yank-from-mail-reply-buffer nil))
 680       (kill-buffer mail-reply-buffer))))
 681
 682 ;;
 683 ;; default body citation func
 684 ;;
 685 (defun wl-default-draft-cite ()
 686   (let ((mail-yank-ignored-headers "[^:]+:")
 687         (mail-yank-prefix "> ")
 688         date from cite-title)
 689     (save-restriction
 690       (if (< (mark t) (point))
 691           (exchange-point-and-mark))
 692       (narrow-to-region (point)(point-max))
 693       (setq date (std11-field-body "date")
 694             from (std11-field-body "from")))
 695     (when (or date from)
 696       (insert (format "At %s,\n%s wrote:\n"
 697                       (or date "some time ago")
 698                       (if wl-default-draft-cite-decorate-author
 699                           (funcall wl-summary-from-function
 700                                    (or from "you"))
 701                         (or from "you")))))
 702     (mail-indent-citation)))
 703
 704 (defvar wl-draft-buffer nil "Draft buffer to yank content.")
 705 (defun wl-draft-yank-to-draft-buffer (buffer)
 706   "Yank BUFFER content to `wl-draft-buffer'."
 707   (set-buffer wl-draft-buffer)
 708   (let ((mail-reply-buffer buffer))
 709     (wl-draft-yank-from-mail-reply-buffer nil)
 710     (kill-buffer buffer)))
 711
 712 (defun wl-draft-yank-original (&optional arg)
 713   "Yank original message."
 714   (interactive "P")
 715   (if arg
 716       (let (buf mail-reply-buffer)
 717         (elmo-set-work-buf
 718          (insert "\n")
 719          (yank)
 720          (setq buf (current-buffer)))
 721         (setq mail-reply-buffer buf)
 722         (wl-draft-yank-from-mail-reply-buffer nil))
 723     (wl-draft-yank-current-message-entity)))
 724
 725 (defun wl-draft-hide (editing-buffer)
 726   "Hide the editing draft buffer if possible."
 727   (when (and editing-buffer
 728              (buffer-live-p editing-buffer)
 729              (get-buffer-window editing-buffer))
 730     (select-window (get-buffer-window editing-buffer))
 731     (let ((sum-buf wl-draft-buffer-cur-summary-buffer)
 732           fld-buf sum-win fld-win)
 733       (if (and wl-draft-use-frame
 734                (> (length (visible-frame-list)) 1))
 735           ;; hide draft frame
 736           (delete-frame)
 737         ;; hide draft window
 738         (or (one-window-p)
 739             (delete-window))
 740         ;; stay folder window if required
 741         (when wl-stay-folder-window
 742           (if (setq fld-buf (get-buffer wl-folder-buffer-name))
 743               (if (setq fld-win (get-buffer-window fld-buf))
 744                   (select-window fld-win)
 745                 (if wl-draft-resume-folder-window ;; resume folder window
 746                     (switch-to-buffer fld-buf)))))
 747         (if (buffer-live-p sum-buf)
 748             (if (setq sum-win (get-buffer-window sum-buf t))
 749                 ;; if Summary is on the frame, select it.
 750                 (select-window sum-win)
 751               ;; if summary is not on the frame, switch to it.
 752               (if (and wl-stay-folder-window
 753                        (or wl-draft-resume-folder-window fld-win))
 754                   (wl-folder-select-buffer sum-buf)
 755                 (switch-to-buffer sum-buf))))))))
 756
 757 (defun wl-draft-delete (editing-buffer)
 758   "Kill the editing draft buffer and delete the file corresponds to it."
 759   (save-excursion
 760     (when editing-buffer
 761       (set-buffer editing-buffer)
 762       (when wl-draft-buffer-message-number
 763         (elmo-folder-delete-messages (wl-draft-get-folder)
 764                                      (list
 765                                       wl-draft-buffer-message-number))
 766         (wl-draft-config-info-operation wl-draft-buffer-message-number
 767                                         'delete))
 768       (set-buffer-modified-p nil)               ; force kill
 769       (kill-buffer editing-buffer))))
 770
 771 (defun wl-draft-kill (&optional force-kill)
 772   "Kill current draft buffer and quit editing."
 773   (interactive "P")
 774   (save-excursion
 775     (when (and (or (eq major-mode 'wl-draft-mode)
 776                    (eq major-mode 'mail-mode))
 777                (or force-kill
 778                    (yes-or-no-p "Kill Current Draft? ")))
 779       (let ((cur-buf (current-buffer)))
 780         (when (and wl-draft-parent-number
 781                    (not (string= wl-draft-parent-folder "")))
 782           (let* ((number wl-draft-parent-number)
 783                  (folder-name wl-draft-parent-folder)
 784                  (folder (wl-folder-get-elmo-folder folder-name))
 785                  buffer)
 786             (if (and (setq buffer (wl-summary-get-buffer folder-name))
 787                      (with-current-buffer buffer
 788                        (string= (wl-summary-buffer-folder-name)
 789                                 folder-name)))
 790                 (with-current-buffer buffer
 791                   (elmo-folder-unset-flag folder (list number) 'answered)
 792                   (when (wl-summary-jump-to-msg number)
 793                     (wl-summary-update-persistent-mark)))
 794               (elmo-folder-open folder 'load-msgdb)
 795               (elmo-folder-unset-flag folder (list number) 'answered)
 796               (elmo-folder-close folder))))
 797         (wl-draft-hide cur-buf)
 798         (wl-draft-delete cur-buf)))
 799     (message "")))
 800
 801 (defun wl-draft-fcc ()
 802   "Add a new Fcc field, with file name completion."
 803   (interactive)
 804   (or (mail-position-on-field "fcc" t)  ;Put new field after exiting Fcc.
 805       (mail-position-on-field "to"))
 806   (insert "\nFcc: "))
 807
 808 ;; Imported from message.el.
 809 (defun wl-draft-elide-region (b e)
 810   "Elide the text in the region.
 811 An ellipsis (from `wl-draft-elide-ellipsis') will be inserted where the
 812 text was killed."
 813   (interactive "r")
 814   (kill-region b e)
 815   (insert wl-draft-elide-ellipsis))
 816
 817 ;; Imported from message.el.
 818 (defun wl-draft-beginning-of-line (&optional n)
 819   "Move point to beginning of header value or to beginning of line."
 820   (interactive "p")
 821   (let ((zrs 'zmacs-region-stays))
 822     (when (and (interactive-p) (boundp zrs))
 823       (set zrs t)))
 824   (if (wl-draft-point-in-header-p)
 825       (let* ((here (point))
 826              (bol (progn (beginning-of-line n) (point)))
 827              (eol (line-end-position))
 828              (eoh (and (looking-at "[^ \t]")
 829                        (re-search-forward ": *" eol t))))
 830         (if (and eoh (or (> here eoh) (= here bol)))
 831             (goto-char eoh)
 832           (goto-char bol)))
 833     (beginning-of-line n)))
 834
 835 (defun wl-draft-point-in-header-p ()
 836   "Return t if point is in the header."
 837   (save-excursion
 838     (let ((p (point)))
 839       (goto-char (point-min))
 840       (not (re-search-forward
 841             (concat "^" (regexp-quote mail-header-separator) "\n")
 842             p t)))))
 843
 844 ;; function for wl-sent-message-via
 845
 846 (defmacro wl-draft-sent-message-p (type)
 847   (` (eq (nth 1 (assq (, type) wl-sent-message-via)) 'sent)))
 848
 849 (defmacro wl-draft-set-sent-message (type result &optional server-port)
 850   (` (let ((element (assq (, type) wl-sent-message-via)))
 851        (if element
 852            (unless (eq (nth 1 element) (, result))
 853              (setcdr element (list (, result) (, server-port)))
 854              (setq wl-sent-message-modified t))
 855          (push (list (, type) (, result) (, server-port)) wl-sent-message-via)
 856          (setq wl-sent-message-modified t)))))
 857
 858 (defun wl-draft-sent-message-results ()
 859   (let ((results wl-sent-message-via)
 860         unplugged-via sent-via)
 861     (while results
 862       (cond ((eq (nth 1 (car results)) 'unplugged)
 863              (push (caar results) unplugged-via))
 864             ((eq (nth 1 (car results)) 'sent)
 865              (push (caar results) sent-via)))
 866       (setq results (cdr results)))
 867     (list unplugged-via sent-via)))
 868
 869 (defun wl-draft-write-sendlog (status proto server to id)
 870   "Write send log file, if `wl-draft-sendlog' is non-nil."
 871   (when wl-draft-sendlog
 872     (with-temp-buffer
 873       (let* ((filename (expand-file-name wl-draft-sendlog-filename
 874                                          elmo-msgdb-directory))
 875              (filesize (nth 7 (file-attributes filename)))
 876              (server (if server (concat " server=" server) ""))
 877              (to (if to (cond
 878                          ((memq proto '(fcc queue))
 879                           (format " folder=\"%s\"" to))
 880                          ((eq proto 'nntp)
 881                           (format " ng=<%s>" to))
 882                          (t
 883                           (concat " to="
 884                                   (mapconcat
 885                                    'identity
 886                                    (mapcar '(lambda(x) (format "<%s>" x)) to)
 887                                    ","))))
 888                    ""))
 889              (id (if id (concat " id=" id) ""))
 890              (time (format-time-string "%Y/%m/%d %T")))
 891         (insert (format "%s proto=%s stat=%s%s%s%s\n"
 892                         time proto status server to id))
 893         (if (and wl-draft-sendlog-max-size filesize
 894                  (> filesize wl-draft-sendlog-max-size))
 895             (rename-file filename (concat filename ".old") t))
 896         (if (file-writable-p filename)
 897             (write-region-as-binary (point-min) (point-max)
 898                                     filename t 'no-msg)
 899           (message "%s is not writable." filename))))))
 900
 901 (defun wl-draft-get-header-delimiter (&optional delete)
 902   ;; If DELETE is non-nil, replace the header delimiter with a blank line
 903   (let (delimline)
 904     (goto-char (point-min))
 905     (when (re-search-forward
 906            (concat "^" (regexp-quote mail-header-separator) "$\\|^$") nil t)
 907       (replace-match "")
 908       (if delete
 909           (forward-char -1))
 910       (setq delimline (point-marker)))
 911     delimline))
 912
 913 (defun wl-draft-send-mail-with-qmail ()
 914   "Pass the prepared message buffer to qmail-inject.
 915 Refer to the documentation for the variable `send-mail-function'
 916 to find out how to use this."
 917   (if (and wl-draft-qmail-send-plugged
 918            (not (elmo-plugged-p)))
 919       (wl-draft-set-sent-message 'mail 'unplugged)
 920     ;; send the message
 921     (run-hooks 'wl-mail-send-pre-hook) ;; X-PGP-Sig, Cancel-Lock
 922     (let ((id (std11-field-body "Message-ID"))
 923           (to (std11-field-body "To")))
 924       (case
 925           (as-binary-process
 926            (apply
 927             'call-process-region 1 (point-max) wl-qmail-inject-program
 928             nil nil nil
 929             wl-qmail-inject-args))
 930         ;; qmail-inject doesn't say anything on it's stdout/stderr,
 931         ;; we have to look at the retval instead
 932         (0   (progn
 933                (wl-draft-set-sent-message 'mail 'sent)
 934                (wl-draft-write-sendlog 'ok 'qmail nil (list to) id)))
 935         (1   (error "`qmail-inject' reported permanent failure"))
 936         (111 (error "`qmail-inject' reported transient failure"))
 937         ;; should never happen
 938         (t   (error "`qmail-inject' reported unknown failure"))))))
 939
 940 (defun wl-draft-parse-msg-id-list-string (string)
 941   "Get msg-id list from STRING."
 942   (let (msg-id-list)
 943     (dolist (parsed-id (std11-parse-msg-ids-string string))
 944       (when (eq (car parsed-id) 'msg-id)
 945         (setq msg-id-list (cons (std11-msg-id-string parsed-id)
 946                                 msg-id-list))))
 947     (nreverse msg-id-list)))
 948
 949 (defun wl-draft-eword-encode-address-list (string &optional column)
 950   "Encode header field STRING as list of address, and return the result.
 951 Cause an error when STRING contains invalid address.
 952 Optional argument COLUMN is start-position of the field."
 953   (car (eword-encode-rword-list
 954         (or column eword-encode-default-start-column)
 955         (eword-encode-addresses-to-rword-list
 956          (wl-draft-std11-parse-addresses (std11-lexical-analyze string))))))
 957
 958 (defun wl-draft-std11-parse-addresses (lal)
 959   (let ((ret (std11-parse-address lal)))
 960     (when (and (not (and (eq (length lal) 1)
 961                          (eq (car (car lal)) 'spaces)))
 962                (null ret))
 963       (error "Error while parsing address"))
 964     (if ret
 965         (let ((dest (list (car ret))))
 966           (setq lal (cdr ret))
 967           (while (and (setq ret (std11-parse-ascii-token lal))
 968                       (string-equal (cdr (assq 'specials (car ret))) ",")
 969                       (setq ret (std11-parse-address (cdr ret)))
 970                       )
 971             (setq dest (cons (car ret) dest))
 972             (setq lal (cdr ret)))
 973           (while (eq 'spaces (car (car lal)))
 974             (setq lal (cdr lal)))
 975           (if lal (error "Error while parsing address"))
 976           (nreverse dest)))))
 977
 978 (defun wl-draft-parse-mailbox-list (field &optional remove-group-list)
 979   "Get mailbox list of FIELD from current buffer.
 980 The buffer is expected to be narrowed to just the headers of the message.
 981 If optional argument REMOVE-GROUP-LIST is non-nil, remove group list content
 982 from current buffer."
 983   (save-excursion
 984     (let ((case-fold-search t)
 985           (inhibit-read-only t)
 986           addresses address
 987           mailbox-list beg seq has-group-list)
 988       (goto-char (point-min))
 989       (while (re-search-forward (concat "^" (regexp-quote field) "[\t ]*:")
 990                                 nil t)
 991         (setq beg (point))
 992         (re-search-forward "^[^ \t]" nil 'move)
 993         (beginning-of-line)
 994         (skip-chars-backward "\n")
 995         (setq seq (std11-lexical-analyze
 996                    (buffer-substring-no-properties beg (point))))
 997         (setq addresses (wl-draft-std11-parse-addresses seq))
 998         (while addresses
 999           (cond ((eq (car (car addresses)) 'group)
1000                  (setq has-group-list t)
1001                  (setq mailbox-list
1002                        (nconc mailbox-list
1003                               (mapcar
1004                                'std11-address-string
1005                                (nth 2 (car addresses))))))
1006                 ((eq (car (car addresses)) 'mailbox)
1007                  (setq address (nth 1 (car addresses)))
1008                  (setq mailbox-list
1009                        (nconc mailbox-list
1010                               (list
1011                                (std11-addr-to-string
1012                                 (if (eq (car address) 'phrase-route-addr)
1013                                     (nth 2 address)
1014                                   (cdr address))))))))
1015           (setq addresses (cdr addresses)))
1016         (when (and remove-group-list has-group-list)
1017           (delete-region beg (point))
1018           (insert (wl-address-string-without-group-list-contents seq))))
1019       mailbox-list)))
1020
1021 (defun wl-draft-deduce-address-list (buffer header-start header-end)
1022   "Get address list suitable for smtp RCPT TO:<address>.
1023 Group list content is removed if `wl-draft-remove-group-list-contents' is
1024 non-nil."
1025   (let ((fields (if (and wl-draft-doing-mime-bcc
1026                          wl-draft-disable-bcc-for-mime-bcc)
1027                     '("to" "cc")
1028                   '("to" "cc" "bcc")))
1029         (resent-fields '("resent-to" "resent-cc" "resent-bcc"))
1030         (case-fold-search t)
1031         addrs recipients)
1032     (save-excursion
1033       (save-restriction
1034         (narrow-to-region header-start header-end)
1035         (goto-char (point-min))
1036         (save-excursion
1037           (if (re-search-forward "^resent-to[\t ]*:" nil t)
1038               (setq fields resent-fields)))
1039         (while fields
1040           (setq recipients
1041                 (nconc recipients
1042                        (wl-draft-parse-mailbox-list
1043                         (car fields)
1044                         wl-draft-remove-group-list-contents)))
1045           (setq fields (cdr fields)))
1046         recipients))))
1047
1048 ;;
1049 ;; from Semi-gnus
1050 ;;
1051 (defun wl-draft-send-mail-with-smtp ()
1052   "Send the prepared message buffer with SMTP."
1053   (require 'smtp)
1054   (let* ((errbuf (if mail-interactive
1055                      (generate-new-buffer " smtp errors")
1056                    0))
1057          (case-fold-search t)
1058          (default-case-fold-search t)
1059          (sender (or wl-envelope-from
1060                      (wl-address-header-extract-address wl-from)))
1061          (delimline (save-excursion
1062                       (goto-char (point-min))
1063                       (re-search-forward
1064                        (concat "^" (regexp-quote mail-header-separator)
1065                                "$\\|^$") nil t)
1066                       (point-marker)))
1067          (smtp-server
1068           (or wl-smtp-posting-server smtp-server "localhost"))
1069          (smtp-service (or wl-smtp-posting-port smtp-service))
1070          (smtp-local-domain (or smtp-local-domain wl-local-domain))
1071          (id (std11-field-body "message-id"))
1072          recipients)
1073     (if (not (elmo-plugged-p smtp-server smtp-service))
1074         (wl-draft-set-sent-message 'mail 'unplugged
1075                                    (cons smtp-server smtp-service))
1076       (unwind-protect
1077           (save-excursion
1078             ;; Instead of `smtp-deduce-address-list'.
1079             (setq recipients (wl-draft-deduce-address-list
1080                               (current-buffer) (point-min) delimline))
1081             (unless recipients (error "No recipients"))
1082             ;; Insert an extra newline if we need it to work around
1083             ;; Sun's bug that swallows newlines.
1084             (goto-char (1+ delimline))
1085             (if (eval mail-mailer-swallows-blank-line)
1086                 (newline))
1087             (run-hooks 'wl-mail-send-pre-hook) ;; X-PGP-Sig, Cancel-Lock
1088             (if mail-interactive
1089                 (save-excursion
1090                   (set-buffer errbuf)
1091                   (erase-buffer)))
1092             (wl-draft-delete-field "bcc" delimline)
1093             (wl-draft-delete-field "resent-bcc" delimline)
1094             (let (process-connection-type)
1095               (as-binary-process
1096                (when recipients
1097                  (wl-smtp-extension-bind
1098                   (condition-case err
1099                       (smtp-send-buffer sender recipients (current-buffer))
1100                     (error
1101                      (wl-draft-write-sendlog 'failed 'smtp smtp-server
1102                                              recipients id)
1103                      (if (and (eq (car err) 'smtp-response-error)
1104                               (= (nth 1 err) 535))
1105                          (elmo-remove-passwd
1106                           (wl-smtp-password-key
1107                            smtp-sasl-user-name
1108                            (car smtp-sasl-mechanisms)
1109                            smtp-server)))
1110                      (signal (car err) (cdr err)))
1111                     (quit
1112                      (wl-draft-write-sendlog 'uncertain 'smtp smtp-server
1113                                              recipients id)
1114                      (signal (car err) (cdr err)))))
1115                  (wl-draft-set-sent-message 'mail 'sent)
1116                  (wl-draft-write-sendlog
1117                   'ok 'smtp smtp-server recipients id)))))
1118         (if (bufferp errbuf)
1119             (kill-buffer errbuf))))))
1120
1121 (defun wl-draft-send-mail-with-pop-before-smtp ()
1122   "Send the prepared message buffer with POP-before-SMTP."
1123   (require 'elmo-pop3)
1124   (let ((folder
1125          (luna-make-entity
1126           'elmo-pop3-folder
1127           :user   (or wl-pop-before-smtp-user
1128                       elmo-pop3-default-user)
1129           :server (or wl-pop-before-smtp-server
1130                       elmo-pop3-default-server)
1131           :port   (or wl-pop-before-smtp-port
1132                       elmo-pop3-default-port)
1133           :auth   (or wl-pop-before-smtp-authenticate-type
1134                       elmo-pop3-default-authenticate-type)
1135           :stream-type (elmo-get-network-stream-type
1136                         (or wl-pop-before-smtp-stream-type
1137                             elmo-pop3-default-stream-type))))
1138         session)
1139     (condition-case error
1140         (progn
1141           (setq session (elmo-pop3-get-session folder))
1142           (when session (elmo-network-close-session session)))
1143       (error
1144        (unless (string= (nth 1 error) "Unplugged")
1145          (signal (car error) (cdr error))))))
1146   (wl-draft-send-mail-with-smtp))
1147
1148 (defun wl-draft-insert-required-fields (&optional force-msgid)
1149   "Insert Message-ID, Date, and From field.
1150 If FORCE-MSGID, insert message-id regardless of `wl-insert-message-id'."
1151   ;; Insert Message-Id field...
1152   (goto-char (point-min))
1153   (when (and (or force-msgid
1154                  wl-insert-message-id)
1155              (not (re-search-forward "^Message-ID[ \t]*:" nil t)))
1156     (insert (concat "Message-ID: "
1157                     (funcall wl-message-id-function)
1158                     "\n")))
1159   ;; Insert date field.
1160   (goto-char (point-min))
1161   (or (re-search-forward "^Date[ \t]*:" nil t)
1162       (wl-draft-insert-date-field))
1163   ;; Insert from field.
1164   (goto-char (point-min))
1165   (or (re-search-forward "^From[ \t]*:" nil t)
1166       (wl-draft-insert-from-field)))
1167
1168 (defun wl-draft-normal-send-func (editing-buffer kill-when-done)
1169   "Send the message in the current buffer."
1170   (save-restriction
1171     (narrow-to-region (goto-char (point-min))
1172                       (if (re-search-forward
1173                            (concat
1174                             "^" (regexp-quote mail-header-separator) "$")
1175                            nil t)
1176                           (match-beginning 0)
1177                         (point-max)))
1178     (wl-draft-insert-required-fields)
1179     ;; ignore any blank lines in the header
1180     (while (progn (goto-char (point-min))
1181                   (re-search-forward "\n[ \t]*\n\n*" nil t))
1182       (replace-match "\n"))
1183     (goto-char (point-min))
1184     (while (re-search-forward
1185             "^[^ \t\n:]+:[ \t]*\\(.*\\(\n[ \t].*\\)*\\)\n"
1186             nil t)
1187       (when (string= "" (match-string 1))
1188         (replace-match ""))))
1189 ;;;  (run-hooks 'wl-mail-send-pre-hook) ;; X-PGP-Sig, Cancel-Lock
1190   (wl-draft-dispatch-message)
1191   (when kill-when-done
1192     ;; hide editing-buffer.
1193     (wl-draft-hide editing-buffer)
1194     ;; delete editing-buffer and its file.
1195     (wl-draft-delete editing-buffer)))
1196
1197 (defun wl-draft-dispatch-message (&optional mes-string)
1198   "Send the message in the current buffer.  Not modified the header fields."
1199   (let (delimline mime-bcc)
1200     (if (and wl-draft-verbose-send mes-string)
1201         (message "%s" mes-string))
1202     ;; get fcc folders.
1203     (setq delimline (wl-draft-get-header-delimiter t))
1204     (unless wl-draft-fcc-list
1205       (setq wl-draft-fcc-list (wl-draft-get-fcc-list delimline)))
1206     ;;
1207     (setq wl-sent-message-modified nil)
1208     (unwind-protect
1209         (progn
1210           (if (and (wl-message-mail-p)
1211                    (not (wl-draft-sent-message-p 'mail)))
1212               (if (or (not (or wl-draft-force-queuing
1213                                wl-draft-force-queuing-mail))
1214                       (memq 'mail wl-sent-message-queued))
1215                   (progn
1216                     (setq mime-bcc (wl-draft-mime-bcc-field))
1217                     (funcall wl-draft-send-mail-function)
1218                     (when (not (zerop (length mime-bcc)))
1219                       (wl-draft-do-mime-bcc mime-bcc)))
1220                 (push 'mail wl-sent-message-queued)
1221                 (wl-draft-set-sent-message 'mail 'unplugged)))
1222           (if (and (wl-message-news-p)
1223                    (not (wl-draft-sent-message-p 'news))
1224                    (not (wl-message-field-exists-p "Resent-to")))
1225               (if (or (not (or wl-draft-force-queuing
1226                                wl-draft-force-queuing-news))
1227                       (memq 'news wl-sent-message-queued))
1228                   (funcall wl-draft-send-news-function)
1229                 (push 'news wl-sent-message-queued)
1230                 (wl-draft-set-sent-message 'news 'unplugged))))
1231       (let* ((status (wl-draft-sent-message-results))
1232              (unplugged-via (car status))
1233              (sent-via (nth 1 status)))
1234         ;; If one sent, process fcc folder.
1235         (if (and sent-via wl-draft-fcc-list)
1236             (progn
1237               (wl-draft-do-fcc (wl-draft-get-header-delimiter)
1238                                wl-draft-fcc-list)
1239               (setq wl-draft-fcc-list nil)))
1240         (if wl-draft-use-cache
1241             (let ((id (std11-field-body "Message-ID"))
1242                   (elmo-enable-disconnected-operation t))
1243               (elmo-file-cache-save (elmo-file-cache-get-path id)
1244                                     nil)))
1245         ;; If one unplugged, append queue.
1246         (when (and unplugged-via
1247                    wl-sent-message-modified)
1248           (if wl-draft-enable-queuing
1249               (progn
1250                 (wl-draft-queue-append wl-sent-message-via)
1251                 (setq wl-sent-message-modified 'requeue))
1252             (error "Unplugged")))
1253         (when wl-draft-verbose-send
1254           (if (and unplugged-via sent-via);; combined message
1255               (progn
1256                 (setq wl-draft-verbose-msg
1257                       (format "Sending%s and Queuing%s..."
1258                               sent-via unplugged-via))
1259                 (message "%sdone" wl-draft-verbose-msg))
1260             (if mes-string
1261                 (message "%s%s"
1262                          mes-string
1263                          (if sent-via "done" "failed"))))))))
1264   (not wl-sent-message-modified)) ;; return value
1265
1266 (defun wl-draft-raw-send (&optional kill-when-done force-pre-hook mes-string)
1267   "Force send current buffer as raw message."
1268   (interactive)
1269   (save-excursion
1270     (let (wl-interactive-send
1271 ;;;       wl-draft-verbose-send
1272           (wl-mail-send-pre-hook (and force-pre-hook wl-mail-send-pre-hook))
1273           (wl-news-send-pre-hook (and force-pre-hook wl-news-send-pre-hook))
1274           mail-send-hook
1275           mail-send-actions)
1276       (wl-draft-send kill-when-done mes-string))))
1277
1278 (defun wl-draft-clone-local-variables ()
1279   (let ((locals (buffer-local-variables))
1280         result)
1281     (while locals
1282       (when (and (consp (car locals))
1283                  (car (car locals))
1284                  (string-match wl-draft-clone-local-variable-regexp
1285                                (symbol-name (car (car locals)))))
1286         (wl-append result (list (car (car locals)))))
1287       (setq locals (cdr locals)))
1288     result))
1289
1290 (defcustom wl-draft-send-confirm-with-preview t
1291   "Non-nil to invoke preview through confirmation of sending.
1292 This variable is valid when `wl-interactive-send' has non-nil value."
1293   :type 'boolean
1294   :group 'wl-draft)
1295
1296 (defun wl-draft-send-confirm ()
1297   (let (answer)
1298     (unwind-protect
1299         (condition-case quit
1300             (progn
1301               (when wl-draft-send-confirm-with-preview
1302                 (wl-draft-preview-message))
1303               (save-excursion
1304                 (goto-char (point-min)) ; to show recipients in header
1305                 (catch 'done
1306                   (while t
1307                     (discard-input)
1308                     (message "Send current draft? <y/n/j(down)/k(up)> ")
1309                     (setq answer (let ((cursor-in-echo-area t)) (read-char)))
1310                     (cond
1311                      ((or (eq answer ?y)
1312                           (eq answer ?Y)
1313                           (eq answer ? ))
1314                   (throw 'done t))
1315                      ((or (eq answer ?v)
1316                           (eq answer ?j)
1317                           (eq answer ?J))
1318                       (condition-case err
1319                           (scroll-up)
1320                         (error nil)))
1321                      ((or (eq answer ?^)
1322                           (eq answer ?k)
1323                           (eq answer ?K))
1324                       (condition-case err
1325                           (scroll-down)
1326                         (error nil)))
1327                      (t
1328                       (throw 'done nil)))))))
1329           (quit nil))
1330       (when wl-draft-send-confirm-with-preview
1331         (mime-preview-quit)))))
1332
1333 (defun wl-draft-send (&optional kill-when-done mes-string)
1334   "Send current draft message.
1335 If KILL-WHEN-DONE is non-nil, current draft buffer is killed"
1336   (interactive)
1337   ;; Don't call this explicitly.
1338   ;; Added to 'wl-draft-send-hook (by teranisi)
1339   ;; (wl-draft-config-exec)
1340   (run-hooks 'wl-draft-send-hook)
1341   (when (or (not wl-interactive-send)
1342             (wl-draft-send-confirm))
1343     (let ((send-mail-function 'wl-draft-raw-send)
1344           (editing-buffer (current-buffer))
1345           (sending-buffer (wl-draft-generate-clone-buffer
1346                            " *wl-draft-sending-buffer*"
1347                            (append wl-draft-config-variables
1348                                    (wl-draft-clone-local-variables))))
1349           (wl-draft-verbose-msg nil)
1350           err)
1351       (unwind-protect
1352           (save-excursion
1353             (set-buffer sending-buffer)
1354             (if (and (not (wl-message-mail-p))
1355                      (not (wl-message-news-p)))
1356                 (error "No recipient is specified"))
1357             (expand-abbrev)             ; for mail-abbrevs
1358             (let ((mime-header-encode-method-alist
1359                    (append
1360                     '((wl-draft-eword-encode-address-list
1361                        .  (To Cc Bcc Resent-To Resent-Cc Resent-Bcc From)))
1362                     (if (boundp 'mime-header-encode-method-alist)
1363                         (symbol-value 'mime-header-encode-method-alist)))))
1364               (run-hooks 'mail-send-hook) ; translate buffer
1365               )
1366             ;;
1367             (if wl-draft-verbose-send
1368                 (message "%s" (or mes-string "Sending...")))
1369             (funcall wl-draft-send-function editing-buffer kill-when-done)
1370             ;; Now perform actions on successful sending.
1371             (while mail-send-actions
1372               (condition-case ()
1373                   (apply (car (car mail-send-actions))
1374                          (cdr (car mail-send-actions)))
1375                 (error))
1376               (setq mail-send-actions (cdr mail-send-actions)))
1377             (if wl-draft-verbose-send
1378                 (message "%sdone"
1379                          (or wl-draft-verbose-msg
1380                              mes-string
1381                              "Sending..."))))
1382         ;; kill sending buffer, anyway.
1383         (and (buffer-live-p sending-buffer)
1384              (kill-buffer sending-buffer))))))
1385
1386 (defun wl-draft-mime-bcc-field ()
1387   "Return the MIME-Bcc field body.  The field is deleted."
1388   (prog1 (std11-field-body wl-draft-mime-bcc-field-name)
1389     (wl-draft-delete-field wl-draft-mime-bcc-field-name)))
1390
1391 (defun wl-draft-do-mime-bcc (field-body)
1392   "Send MIME-Bcc (Encapsulated blind carbon copy)."
1393   (let ((orig-from (mime-decode-field-body (std11-field-body "from")
1394                                            'From))
1395         (orig-subj (mime-decode-field-body (or (std11-field-body "subject")
1396                                                "")
1397                                            'Subject))
1398         (recipients (wl-parse-addresses field-body))
1399         (draft-buffer (current-buffer))
1400         wl-draft-use-frame)
1401     (save-window-excursion
1402       (when (and (not wl-draft-doing-mime-bcc) ; To avoid infinite loop.
1403                  (not (zerop (length field-body))))
1404         (let ((wl-draft-doing-mime-bcc t))
1405           (dolist (recipient recipients)
1406             (wl-draft-create-buffer)
1407             (wl-draft-create-contents
1408              (append `((From . ,orig-from)
1409                        (To . ,recipient)
1410                        (Subject . ,(concat "A blind carbon copy ("
1411                                            orig-subj
1412                                            ")")))
1413                      (wl-draft-default-headers)))
1414             (wl-draft-insert-mail-header-separator)
1415             (wl-draft-prepare-edit)
1416             (goto-char (point-max))
1417             (insert (or wl-draft-mime-bcc-body
1418                         "This is a blind carbon copy.")
1419                     "\n")
1420             (mime-edit-insert-tag "message" "rfc822")
1421             (insert-buffer draft-buffer)
1422             (let (wl-interactive-send)
1423               (wl-draft-send 'kill-when-done))))))))
1424
1425 (defun wl-draft-save ()
1426   "Save current draft."
1427   (interactive)
1428   (if (buffer-modified-p)
1429       (progn
1430         (message "Saving...")
1431         (let ((msg (buffer-substring-no-properties (point-min) (point-max)))
1432               next-number)
1433           (when wl-draft-buffer-message-number
1434             (elmo-folder-delete-messages (wl-draft-get-folder)
1435                                          (list wl-draft-buffer-message-number))
1436             (wl-draft-config-info-operation wl-draft-buffer-message-number
1437                                             'delete))
1438           (elmo-folder-check (wl-draft-get-folder))
1439           ;; If no header separator, insert it.
1440           (with-temp-buffer
1441             (insert msg)
1442             (goto-char (point-min))
1443             (unless (re-search-forward
1444                      (concat "^" (regexp-quote mail-header-separator) "$")
1445                      nil t)
1446               (goto-char (point-min))
1447               (if (re-search-forward "\n\n" nil t)
1448                   (replace-match (concat "\n" mail-header-separator "\n"))
1449                 (goto-char (point-max))
1450                 (insert (if (eq (char-before) ?\n) "" "\n")
1451                         mail-header-separator "\n")))
1452             (let ((mime-header-encode-method-alist
1453                    '((eword-encode-unstructured-field-body))))
1454               (mime-edit-translate-buffer))
1455             (wl-draft-get-header-delimiter t)
1456             (setq next-number
1457                   (elmo-folder-next-message-number (wl-draft-get-folder)))
1458             (elmo-folder-append-buffer (wl-draft-get-folder)))
1459           (elmo-folder-check (wl-draft-get-folder))
1460           (elmo-folder-commit (wl-draft-get-folder))
1461           (setq wl-draft-buffer-message-number next-number)
1462           (rename-buffer (format "%s/%d" wl-draft-folder next-number))
1463           (setq buffer-file-name (buffer-name))
1464           (set-buffer-modified-p nil)
1465           (wl-draft-config-info-operation wl-draft-buffer-message-number 'save)
1466           (message "Saving...done")))
1467     (message "(No changes need to be saved)")))
1468
1469 (defun wl-draft-mimic-kill-buffer ()
1470   "Kill the current (draft) buffer with query."
1471   (interactive)
1472   (let ((bufname (read-buffer (format "Kill buffer: (default %s) "
1473                                       (buffer-name))))
1474         wl-draft-use-frame)
1475     (if (or (not bufname)
1476             (string-equal bufname "")
1477             (string-equal bufname (buffer-name)))
1478         (let ((bufname (current-buffer)))
1479           (when (or (not (buffer-modified-p))
1480                     (yes-or-no-p
1481                      (format "Buffer %s modified; kill anyway? " bufname)))
1482             (set-buffer-modified-p nil)
1483             (wl-draft-hide bufname)
1484             (kill-buffer bufname)))
1485       (kill-buffer bufname))))
1486
1487 (defun wl-draft-save-and-exit ()
1488   "Save current draft and exit current draft mode."
1489   (interactive)
1490   (wl-draft-save)
1491   (let ((editing-buffer (current-buffer)))
1492     (wl-draft-hide editing-buffer)
1493     (kill-buffer editing-buffer)))
1494
1495 (defun wl-draft-send-and-exit ()
1496   "Send current draft message and kill it."
1497   (interactive)
1498   (wl-draft-send t))
1499
1500 (defun wl-draft-send-from-toolbar ()
1501   (interactive)
1502   (let ((wl-interactive-send t))
1503     (wl-draft-send-and-exit)))
1504
1505 (defun wl-draft-delete-field (field &optional delimline replace)
1506   (wl-draft-delete-fields (regexp-quote field) delimline replace))
1507
1508 (defun wl-draft-delete-fields (field &optional delimline replace)
1509   (save-restriction
1510     (unless delimline
1511       (goto-char (point-min))
1512       (if (search-forward "\n\n" nil t)
1513           (setq delimline (point))
1514         (setq delimline (point-max))))
1515     (narrow-to-region (point-min) delimline)
1516     (goto-char (point-min))
1517     (let ((regexp (concat "^" field ":"))
1518           (case-fold-search t))
1519       (while (not (eobp))
1520         (if (looking-at regexp)
1521             (progn
1522               (delete-region
1523                (point)
1524                (progn
1525                  (forward-line 1)
1526                  (if (re-search-forward "^[^ \t]" nil t)
1527                      (goto-char (match-beginning 0))
1528                    (point-max))))
1529               (if replace
1530                   (insert (concat field ": " replace "\n"))))
1531           (forward-line 1)
1532           (if (re-search-forward "^[^ \t]" nil t)
1533               (goto-char (match-beginning 0))
1534             (point-max)))))))
1535
1536 (defun wl-draft-get-fcc-list (header-end)
1537   (if (and wl-draft-doing-mime-bcc
1538            wl-draft-disable-fcc-for-mime-bcc)
1539       (progn
1540         (wl-draft-delete-field "fcc")
1541         nil)
1542     (let (fcc-list
1543           (case-fold-search t))
1544       (or (markerp header-end) (error "HEADER-END must be a marker"))
1545       (save-excursion
1546         (goto-char (point-min))
1547         (while (re-search-forward "^Fcc:[ \t]*" header-end t)
1548           (save-match-data
1549             (setq fcc-list
1550                   (append fcc-list
1551                           (split-string
1552                            (buffer-substring-no-properties
1553                             (point)
1554                             (progn
1555                               (end-of-line)
1556                               (skip-chars-backward " \t")
1557                               (point)))
1558                            ",[ \t]*")))
1559             (dolist (folder fcc-list)
1560               (wl-folder-confirm-existence
1561                (wl-folder-get-elmo-folder (eword-decode-string folder)))))
1562           (delete-region (match-beginning 0)
1563                          (progn (forward-line 1) (point)))))
1564       fcc-list)))
1565
1566 (defcustom wl-draft-fcc-append-read-folder-history t
1567   "Non-nil to append fcc'ed folder to `wl-read-folder-history'."
1568   :type 'boolean
1569   :group 'wl-draft)
1570
1571 (defun wl-draft-do-fcc (header-end &optional fcc-list)
1572   (let ((send-mail-buffer (current-buffer))
1573         (tembuf (generate-new-buffer " fcc output"))
1574         (case-fold-search t)
1575         beg end)
1576     (or (markerp header-end) (error "HEADER-END must be a marker"))
1577     (save-excursion
1578       (unless fcc-list
1579         (setq fcc-list (wl-draft-get-fcc-list header-end)))
1580       (set-buffer tembuf)
1581       (erase-buffer)
1582       ;; insert just the headers to avoid moving the gap more than
1583       ;; necessary (the message body could be arbitrarily huge.)
1584       (insert-buffer-substring send-mail-buffer 1 header-end)
1585       (wl-draft-insert-required-fields t)
1586       (goto-char (point-max))
1587       (insert-buffer-substring send-mail-buffer header-end)
1588       (let ((id (std11-field-body "Message-ID"))
1589             (elmo-enable-disconnected-operation t)
1590             cache-saved)
1591         (while fcc-list
1592           (unless (or cache-saved
1593                       (elmo-folder-plugged-p
1594                        (wl-folder-get-elmo-folder (car fcc-list))))
1595             (elmo-file-cache-save id nil) ;; for disconnected operation
1596             (setq cache-saved t))
1597           (if (elmo-folder-append-buffer
1598                (wl-folder-get-elmo-folder
1599                 (eword-decode-string (car fcc-list)))
1600                (and wl-fcc-force-as-read '(read)))
1601               (wl-draft-write-sendlog 'ok 'fcc nil (car fcc-list) id)
1602             (wl-draft-write-sendlog 'failed 'fcc nil (car fcc-list) id))
1603           (if (and wl-draft-fcc-append-read-folder-history
1604                    (boundp 'wl-read-folder-history))
1605               (or (equal (car fcc-list) (car wl-read-folder-history))
1606                   (setq wl-read-folder-history
1607                         (append (list (car fcc-list)) wl-read-folder-history))))
1608           (setq fcc-list (cdr fcc-list)))))
1609     (kill-buffer tembuf)))
1610
1611 (defun wl-draft-on-field-p ()
1612   (if (< (point)
1613          (save-excursion
1614            (goto-char (point-min))
1615            (search-forward (concat "\n" mail-header-separator "\n") nil 0)
1616            (point)))
1617       (if (bolp)
1618           (if (bobp)
1619               t
1620             (save-excursion
1621               (forward-line -1)
1622               (if (or (looking-at ".*,[ \t]?$")
1623                       (looking-at "^[^ \t]+:[ \t]+.*:$")); group list name
1624                   nil t)))
1625         (let ((pos (point)))
1626           (save-excursion
1627             (beginning-of-line)
1628             (if (looking-at "^[ \t]")
1629                 nil
1630               (if (re-search-forward ":" pos t) nil t)))))))
1631
1632 ;;;;;;;;;;;;;;;;
1633 ;;;###autoload
1634 (defun wl-draft (&optional header-alist
1635                            content-type content-transfer-encoding
1636                            body edit-again
1637                            parent-folder)
1638   "Write and send mail/news message with Wanderlust."
1639   (interactive)
1640   (require 'wl)
1641   (unless wl-init
1642     (wl-load-profile)
1643     (wl-folder-init)
1644     (elmo-init)
1645     (wl-plugged-init t))
1646   (let (wl-demo)
1647     (wl-init)) ; returns immediately if already initialized.
1648
1649
1650   (let (buffer header-alist-internal)
1651     (setq buffer (wl-draft-create-buffer parent-folder))
1652     (unless (cdr (assq 'From header-alist))
1653       (setq header-alist
1654             (append (list (cons 'From wl-from)) header-alist)))
1655     (unless (cdr (assq 'To header-alist))
1656       (let ((to))
1657         (when (setq to (and
1658                         (interactive-p)
1659                         ""))
1660           (if (assq 'To header-alist)
1661               (setcdr (assq 'To header-alist) to)
1662             (setq header-alist
1663                   (append header-alist
1664                           (list (cons 'To to))))))))
1665     (unless (cdr (assq 'Subject header-alist))
1666       (if (assq 'Subject header-alist)
1667           (setcdr (assq 'Subject header-alist) "")
1668         (setq header-alist
1669               (append header-alist (list (cons 'Subject ""))))))
1670     (setq header-alist (append header-alist
1671                                (wl-draft-default-headers)
1672                                wl-draft-additional-header-alist
1673                                (if body (list "" (cons 'Body body)))))
1674     (wl-draft-create-contents header-alist)
1675     (if edit-again
1676         (wl-draft-decode-body
1677          content-type content-transfer-encoding))
1678     (wl-draft-insert-mail-header-separator)
1679     (wl-draft-prepare-edit)
1680     (if (interactive-p)
1681         (run-hooks 'wl-mail-setup-hook))
1682     (goto-char (point-min))
1683     (setq buffer-undo-list nil)
1684     (wl-user-agent-compose-internal) ;; user-agent
1685     (cond ((and
1686             (interactive-p)
1687             (string= (cdr (assq 'To header-alist)) ""))
1688            (mail-position-on-field "To"))
1689           (t
1690            (goto-char (point-max))))
1691     buffer))
1692
1693 (defun wl-draft-create-buffer (&optional parent-folder)
1694   (let* ((draft-folder (wl-draft-get-folder))
1695          (parent-folder (or parent-folder (wl-summary-buffer-folder-name)))
1696          (summary-buf (wl-summary-get-buffer parent-folder))
1697          (reply-or-forward
1698           (or (eq this-command 'wl-summary-reply)
1699               (eq this-command 'wl-summary-reply-with-citation)
1700               (eq this-command 'wl-summary-forward)
1701               (eq this-command 'wl-summary-target-mark-forward)
1702               (eq this-command 'wl-summary-target-mark-reply-with-citation)))
1703          (buffer (generate-new-buffer "*draft*")) ; Just for initial name.
1704          change-major-mode-hook)
1705     (set-buffer buffer)
1706     ;; switch-buffer according to draft buffer style.
1707     (if wl-draft-use-frame
1708         (switch-to-buffer-other-frame buffer)
1709       (if reply-or-forward
1710           (case wl-draft-reply-buffer-style
1711             (split
1712              (split-window-vertically)
1713              (other-window 1)
1714              (switch-to-buffer buffer))
1715             (keep
1716              (switch-to-buffer buffer))
1717             (full
1718              (delete-other-windows)
1719              (switch-to-buffer buffer))
1720             (t
1721              (if (functionp wl-draft-reply-buffer-style)
1722                  (funcall wl-draft-reply-buffer-style buffer)
1723                (error "Invalid value for wl-draft-reply-buffer-style"))))
1724         (case wl-draft-buffer-style
1725           (split
1726            (when (eq major-mode 'wl-summary-mode)
1727              (wl-summary-toggle-disp-msg 'off))
1728            (split-window-vertically)
1729            (other-window 1)
1730            (switch-to-buffer buffer))
1731           (keep
1732            (switch-to-buffer buffer))
1733           (full
1734            (delete-other-windows)
1735            (switch-to-buffer buffer))
1736           (t (if (functionp wl-draft-buffer-style)
1737                  (funcall wl-draft-buffer-style buffer)
1738                (error "Invalid value for wl-draft-buffer-style"))))))
1739     (auto-save-mode -1)
1740     (wl-draft-mode)
1741     (set-buffer-multibyte t)            ; draft buffer is always multibyte.
1742     (make-local-variable 'truncate-partial-width-windows)
1743     (setq truncate-partial-width-windows nil)
1744     (setq truncate-lines wl-draft-truncate-lines)
1745     (setq wl-sent-message-via nil)
1746     (setq wl-sent-message-queued nil)
1747     (setq wl-draft-config-exec-flag t)
1748     (setq wl-draft-parent-folder (or parent-folder ""))
1749     (or (eq this-command 'wl-folder-write-current-folder)
1750         (setq wl-draft-buffer-cur-summary-buffer summary-buf))
1751     buffer))
1752
1753 (defun wl-draft-create-contents (header-alist)
1754   "header-alist' sample
1755 '(function  ;; funcall
1756   string    ;; insert string
1757   (symbol . string)    ;;  insert symbol-value: string
1758   (symbol . function)  ;;  (funcall) and if it returns string,
1759                        ;;  insert symbol-value: string
1760   (symbol . nil)       ;;  do nothing
1761   nil                  ;;  do nothing
1762   )"
1763   (unless (eq major-mode 'wl-draft-mode)
1764     (error "`wl-draft-create-header' must be use in wl-draft-mode"))
1765   (let ((halist header-alist)
1766         field value)
1767     (while halist
1768       (cond
1769        ;; function
1770        ((functionp (car halist)) (funcall (car halist)))
1771        ;; string
1772        ((stringp (car halist)) (insert (car halist) "\n"))
1773        ;; cons
1774        ((consp (car halist))
1775         (setq field (car (car halist)))
1776         (setq value (cdr (car halist)))
1777         (cond
1778          ((symbolp field)
1779           (cond
1780            ((eq field 'Body) ; body
1781             (insert value))
1782            ((stringp value) (insert (symbol-name field) ": " value "\n"))
1783            ((functionp value)
1784             (let ((value-return (funcall value)))
1785               (when (stringp value-return)
1786                 (insert (symbol-name field) ": " value-return "\n"))))
1787            ((not value))
1788            (t
1789             (debug))))
1790          ;;
1791          ((not field))
1792          (t
1793           (debug))
1794          )))
1795       (setq halist (cdr halist)))))
1796
1797 (defun wl-draft-prepare-edit ()
1798   (unless (eq major-mode 'wl-draft-mode)
1799     (error "`wl-draft-create-header' must be use in wl-draft-mode"))
1800   (let (change-major-mode-hook)
1801     (wl-draft-editor-mode)
1802     (static-when (boundp 'auto-save-file-name-transforms)
1803       (make-local-variable 'auto-save-file-name-transforms)
1804       (setq auto-save-file-name-transforms
1805             (cons (list (concat (regexp-quote wl-draft-folder)
1806                                 "/\\([0-9]+\\)")
1807                         (concat (expand-file-name
1808                                  "auto-save-"
1809                                  (elmo-folder-msgdb-path
1810                                   (wl-draft-get-folder)))
1811                                 "\\1"))
1812                   auto-save-file-name-transforms)))
1813     (when wl-draft-write-file-function
1814       (add-hook 'local-write-file-hooks wl-draft-write-file-function))
1815     (wl-draft-overload-functions)
1816     (wl-highlight-headers 'for-draft)
1817     (wl-draft-save)
1818     (clear-visited-file-modtime)))
1819
1820 (defun wl-draft-decode-header ()
1821   (save-excursion
1822     (std11-narrow-to-header)
1823     (wl-draft-decode-message-in-buffer)
1824     (widen)))
1825
1826 (defun wl-draft-decode-body (&optional content-type content-transfer-encoding)
1827   (let ((content-type
1828          (or content-type
1829                 (std11-field-body "content-type")))
1830         (content-transfer-encoding
1831          (or content-transfer-encoding
1832              (std11-field-body "content-transfer-encoding")))
1833         delimline)
1834     (save-excursion
1835       (std11-narrow-to-header)
1836       (wl-draft-delete-field "content-type")
1837       (wl-draft-delete-field "content-transfer-encoding")
1838       (goto-char (point-max))
1839       (setq delimline (point-marker))
1840       (widen)
1841       (narrow-to-region delimline (point-max))
1842       (goto-char (point-min))
1843       (when content-type
1844         (insert "Content-type: " content-type "\n"))
1845       (when content-transfer-encoding
1846         (insert "Content-Transfer-Encoding: " content-transfer-encoding "\n"))
1847       (wl-draft-decode-message-in-buffer)
1848       (goto-char (point-min))
1849       (unless (re-search-forward "^$" (point-at-eol) t)
1850         (insert "\n"))
1851       (widen)
1852       delimline)))
1853
1854 ;;; subroutine for wl-draft-create-contents
1855 ;;; must be used in wl-draft-mode
1856 (defun wl-draft-check-new-line ()
1857   (if (not (= (preceding-char) ?\n))
1858       (insert ?\n)))
1859
1860 (defsubst wl-draft-trim-ccs (cc)
1861   (let ((field
1862          (if (functionp cc)
1863              (funcall cc)
1864            cc)))
1865     (if (and field
1866              (null (and wl-draft-delete-myself-from-bcc-fcc
1867                         (elmo-list-member
1868                          (mapcar 'wl-address-header-extract-address
1869                                  (append
1870                                   (wl-parse-addresses (std11-field-body "To"))
1871                                   (wl-parse-addresses (std11-field-body "Cc"))))
1872                          (mapcar 'downcase wl-subscribed-mailing-list)))))
1873         field
1874       nil)))
1875
1876 (defsubst wl-draft-default-headers ()
1877   (list
1878    (cons 'Mail-Reply-To (and wl-insert-mail-reply-to
1879                              (wl-address-header-extract-address
1880                               wl-from)))
1881    (cons 'User-Agent wl-generate-mailer-string-function)
1882    (cons 'Reply-To mail-default-reply-to)
1883    (cons 'Bcc (function
1884                (lambda ()
1885                  (wl-draft-trim-ccs
1886                   (or wl-bcc (and mail-self-blind (user-login-name)))))))
1887    (cons 'Fcc (function
1888                (lambda ()
1889                  (wl-draft-trim-ccs wl-fcc))))
1890    (cons 'Organization wl-organization)
1891    (and wl-auto-insert-x-face
1892         (file-exists-p wl-x-face-file)
1893         'wl-draft-insert-x-face-field-here) ;; allow nil
1894    mail-default-headers
1895    ;; check \n at th end of line for `mail-default-headers'
1896    'wl-draft-check-new-line
1897    ))
1898
1899 (defun wl-draft-insert-mail-header-separator (&optional delimline)
1900   (save-excursion
1901     (if delimline
1902         (goto-char delimline)
1903       (goto-char (point-min))
1904       (if (search-forward "\n\n" nil t)
1905           (delete-backward-char 1)
1906         (goto-char (point-max))))
1907     (wl-draft-check-new-line)
1908     (put-text-property (point)
1909                        (progn
1910                          (insert mail-header-separator "\n")
1911                          (1- (point)))
1912                        'category 'mail-header-separator)
1913     (point)))
1914
1915 ;;;;;;;;;;;;;;;;
1916
1917 (defun wl-draft-elmo-nntp-send ()
1918   (let ((elmo-nntp-post-pre-hook wl-news-send-pre-hook)
1919         (elmo-nntp-default-user
1920          (or wl-nntp-posting-user elmo-nntp-default-user))
1921         (elmo-nntp-default-server
1922          (or wl-nntp-posting-server elmo-nntp-default-server))
1923         (elmo-nntp-default-port
1924          (or wl-nntp-posting-port elmo-nntp-default-port))
1925         (elmo-nntp-default-stream-type
1926          (or wl-nntp-posting-stream-type elmo-nntp-default-stream-type))
1927         (elmo-nntp-default-function wl-nntp-posting-function)
1928         condition)
1929     (if (setq condition (cdr (elmo-string-matched-assoc
1930                               (std11-field-body "Newsgroups")
1931                               wl-nntp-posting-config-alist)))
1932         (if (stringp condition)
1933             (setq elmo-nntp-default-server condition)
1934           (while (car condition)
1935             (set (intern (format "elmo-nntp-default-%s"
1936                                  (symbol-name (caar condition))))
1937                  (cdar condition))
1938             (setq condition (cdr condition)))))
1939     (unless elmo-nntp-default-function
1940       (error "wl-draft-nntp-send: posting-function is nil"))
1941     (if (not (elmo-plugged-p elmo-nntp-default-server elmo-nntp-default-port))
1942         (wl-draft-set-sent-message 'news 'unplugged
1943                                    (cons elmo-nntp-default-server
1944                                          elmo-nntp-default-port))
1945       (funcall elmo-nntp-default-function
1946                elmo-nntp-default-server (current-buffer))
1947       (wl-draft-set-sent-message 'news 'sent)
1948       (wl-draft-write-sendlog 'ok 'nntp elmo-nntp-default-server
1949                               (std11-field-body "Newsgroups")
1950                               (std11-field-body "Message-ID")))))
1951
1952 (defun wl-draft-generate-clone-buffer (name &optional local-variables)
1953   "Generate clone of current buffer named NAME."
1954   (let ((editing-buffer (current-buffer)))
1955     (save-excursion
1956       (set-buffer (generate-new-buffer name))
1957       (erase-buffer)
1958       (wl-draft-mode)
1959       (wl-draft-editor-mode)
1960       (insert-buffer editing-buffer)
1961       (message "")
1962       (while local-variables
1963         (make-local-variable (car local-variables))
1964         (set (car local-variables)
1965              (save-excursion
1966                (set-buffer editing-buffer)
1967                (symbol-value (car local-variables))))
1968         (setq local-variables (cdr local-variables)))
1969       (current-buffer))))
1970
1971 (defun wl-draft-remove-text-plain-tag ()
1972   "Remove text/plain tag of mime-edit."
1973   (when (string= (mime-make-text-tag "plain")
1974                  (buffer-substring-no-properties (point-at-bol)(point-at-eol)))
1975     (delete-region (point-at-bol)(1+ (point-at-eol)))))
1976
1977 (defun wl-draft-reedit (number)
1978   (let ((draft-folder (wl-draft-get-folder))
1979         (wl-draft-reedit t)
1980         (num 0)
1981         buffer change-major-mode-hook body-top)
1982     (setq buffer (get-buffer-create (format "%s/%d" wl-draft-folder
1983                                             number)))
1984     (if wl-draft-use-frame
1985         (switch-to-buffer-other-frame buffer)
1986       (switch-to-buffer buffer))
1987     (set-buffer buffer)
1988     (elmo-message-fetch draft-folder number (elmo-make-fetch-strategy 'entire)
1989                         nil (current-buffer))
1990     (elmo-delete-cr-buffer)
1991     (let ((mime-edit-again-ignored-field-regexp
1992            "^\\(Content-.*\\|Mime-Version\\):"))
1993       (wl-draft-decode-message-in-buffer))
1994     (setq body-top (wl-draft-insert-mail-header-separator))
1995     (auto-save-mode -1)
1996     (wl-draft-mode)
1997     (make-local-variable 'truncate-partial-width-windows)
1998     (setq truncate-partial-width-windows nil)
1999     (setq truncate-lines wl-draft-truncate-lines)
2000     (setq wl-sent-message-via nil)
2001     (setq wl-sent-message-queued nil)
2002     (wl-draft-config-info-operation number 'load)
2003     (goto-char (point-min))
2004     (wl-draft-overload-functions)
2005     (wl-draft-editor-mode)
2006     (static-when (boundp 'auto-save-file-name-transforms)
2007       (make-local-variable 'auto-save-file-name-transforms)
2008       (setq auto-save-file-name-transforms
2009             (cons (list (concat (regexp-quote wl-draft-folder)
2010                                 "/\\([0-9]+\\)")
2011                         (concat (expand-file-name
2012                                  "auto-save-"
2013                                  (elmo-folder-msgdb-path
2014                                   (wl-draft-get-folder)))
2015                                 "\\1"))
2016                   auto-save-file-name-transforms)))
2017     (setq buffer-file-name (buffer-name)
2018           wl-draft-parent-folder ""
2019           wl-draft-buffer-message-number number)
2020     (when wl-draft-write-file-function
2021       (add-hook 'local-write-file-hooks wl-draft-write-file-function))
2022     (wl-highlight-headers 'for-draft)
2023     (goto-char body-top)
2024     (run-hooks 'wl-draft-reedit-hook)
2025     (goto-char (point-max))
2026     buffer))
2027
2028 (defmacro wl-draft-body-goto-top ()
2029   (` (progn
2030        (goto-char (point-min))
2031        (if (re-search-forward mail-header-separator nil t)
2032            (forward-char 1)
2033          (goto-char (point-max))))))
2034
2035 (defmacro wl-draft-body-goto-bottom ()
2036   (` (goto-char (point-max))))
2037
2038 (defmacro wl-draft-config-body-goto-header ()
2039   (` (progn
2040        (goto-char (point-min))
2041        (if (re-search-forward mail-header-separator nil t)
2042            (beginning-of-line)
2043          (goto-char (point-max))))))
2044
2045 (defsubst wl-draft-config-sub-eval-insert (content &optional newline)
2046   (let (content-value)
2047     (when (and content
2048                (stringp (setq content-value (eval content))))
2049       (insert content-value)
2050       (if newline (insert "\n")))))
2051
2052 (defun wl-draft-config-sub-body (content)
2053   (wl-draft-body-goto-top)
2054   (delete-region (point) (point-max))
2055   (wl-draft-config-sub-eval-insert content))
2056
2057 (defun wl-draft-config-sub-top (content)
2058   (wl-draft-body-goto-top)
2059   (wl-draft-config-sub-eval-insert content))
2060
2061 (defun wl-draft-config-sub-bottom (content)
2062   (wl-draft-body-goto-bottom)
2063   (wl-draft-config-sub-eval-insert content))
2064
2065 (defun wl-draft-config-sub-header (content)
2066   (wl-draft-config-body-goto-header)
2067   (wl-draft-config-sub-eval-insert content 'newline))
2068
2069 (defun wl-draft-config-sub-header-top (content)
2070   (goto-char (point-min))
2071   (wl-draft-config-sub-eval-insert content 'newline))
2072
2073 (defun wl-draft-config-sub-part-top (content)
2074   (goto-char (mime-edit-content-beginning))
2075   (wl-draft-config-sub-eval-insert content 'newline))
2076
2077 (defun wl-draft-config-sub-part-bottom (content)
2078   (goto-char (mime-edit-content-end))
2079   (wl-draft-config-sub-eval-insert content 'newline))
2080
2081 (defsubst wl-draft-config-sub-file (content)
2082   (let ((coding-system-for-read wl-cs-autoconv)
2083         (file (expand-file-name (eval content))))
2084     (if (file-exists-p file)
2085         (insert-file-contents file)
2086       (error "%s: no exists file" file))))
2087
2088 (defun wl-draft-config-sub-body-file (content)
2089   (wl-draft-body-goto-top)
2090   (delete-region (point) (point-max))
2091   (wl-draft-config-sub-file content))
2092
2093 (defun wl-draft-config-sub-top-file (content)
2094   (wl-draft-body-goto-top)
2095   (wl-draft-config-sub-file content))
2096
2097 (defun wl-draft-config-sub-bottom-file (content)
2098   (wl-draft-body-goto-bottom)
2099   (wl-draft-config-sub-file content))
2100
2101 (defun wl-draft-config-sub-header-file (content)
2102   (wl-draft-config-body-goto-header)
2103   (wl-draft-config-sub-file content))
2104
2105 (defun wl-draft-config-sub-template (content)
2106   (setq wl-draft-config-variables
2107         (wl-template-insert (eval content))))
2108
2109 (defun wl-draft-config-sub-x-face (content)
2110   (if (and (string-match "\\.xbm\\(\\.gz\\)?$" content)
2111            (fboundp 'x-face-insert)) ; x-face.el is installed.
2112       (x-face-insert content)
2113     (wl-draft-replace-field "X-Face" (elmo-get-file-string content t) t)))
2114
2115 (defsubst wl-draft-config-sub-func (field content)
2116   (let (func)
2117     (if (setq func (assq field wl-draft-config-sub-func-alist))
2118         (let (wl-draft-config-variables)
2119           (funcall (cdr func) content)
2120           ;; for wl-draft-config-sub-template
2121           (cons t wl-draft-config-variables)))))
2122
2123 (defsubst wl-draft-config-exec-sub (clist)
2124   (let (config local-variables)
2125     (while clist
2126       (setq config (car clist))
2127       (cond
2128        ((functionp config)
2129         (funcall config))
2130        ((consp config)
2131         (let ((field (car config))
2132               (content (cdr config))
2133               ret-val)
2134           (cond
2135            ((stringp field)
2136             (wl-draft-replace-field field (eval content) t))
2137            ((setq ret-val (wl-draft-config-sub-func field content))
2138             (if (cdr ret-val) ;; for wl-draft-config-sub-template
2139                 (wl-append local-variables (cdr ret-val))))
2140            ((boundp field) ;; variable
2141             (make-local-variable field)
2142             (set field (eval content))
2143             (wl-append local-variables (list field)))
2144            (t
2145             (error "%s: not variable" field)))))
2146        (t
2147         (error "%s: not supported type" config)))
2148       (setq clist (cdr clist)))
2149     local-variables))
2150
2151 (defun wl-draft-prepared-config-exec (&optional config-alist reply-buf)
2152   "Change headers in draft preparation time."
2153   (interactive)
2154   (unless wl-draft-reedit
2155     (let ((config-alist
2156            (or config-alist
2157                (and (boundp 'wl-draft-prepared-config-alist)
2158                     wl-draft-prepared-config-alist)     ;; For compatible.
2159                wl-draft-config-alist)))
2160       (if config-alist
2161           (wl-draft-config-exec config-alist reply-buf)))))
2162
2163 (defun wl-draft-config-exec (&optional config-alist reply-buf)
2164   "Change headers according to the value of `wl-draft-config-alist'.
2165 Automatically applied in draft sending time."
2166   (interactive)
2167   (let ((case-fold-search t)
2168         (alist (or config-alist wl-draft-config-alist))
2169         (reply-buf (or reply-buf (and (buffer-live-p wl-draft-reply-buffer)
2170                                       wl-draft-reply-buffer)))
2171         (local-variables wl-draft-config-variables)
2172         key clist found)
2173     (when (and (or (interactive-p)
2174                    wl-draft-config-exec-flag)
2175                alist)
2176       (save-excursion
2177         (catch 'done
2178           (while alist
2179             (setq key (caar alist)
2180                   clist (cdar alist))
2181             (cond
2182              ((eq key 'reply)
2183               (when (and
2184                      reply-buf
2185                      (save-excursion
2186                        (set-buffer reply-buf)
2187                        (save-restriction
2188                          (std11-narrow-to-header)
2189                          (goto-char (point-min))
2190                          (re-search-forward (car clist) nil t))))
2191                 (wl-draft-config-exec-sub (cdr clist))
2192                 (setq found t)))
2193              ((stringp key)
2194               (when (save-restriction
2195                       (std11-narrow-to-header mail-header-separator)
2196                       (goto-char (point-min))
2197                       (re-search-forward key nil t))
2198                 (wl-append local-variables
2199                            (wl-draft-config-exec-sub clist))
2200                 (setq found t)))
2201              ((eval key)
2202               (wl-append local-variables
2203                          (wl-draft-config-exec-sub clist))
2204               (setq found t)))
2205             (if (and found wl-draft-config-matchone)
2206                 (throw 'done t))
2207             (setq alist (cdr alist))))
2208         (if found
2209             (setq wl-draft-config-exec-flag nil))
2210         (run-hooks 'wl-draft-config-exec-hook)
2211         (put-text-property (point-min)(point-max) 'face nil)
2212         (wl-highlight-message (point-min)(point-max) t)
2213         (setq wl-draft-config-variables
2214               (elmo-uniq-list local-variables))))))
2215
2216 (defun wl-draft-replace-field (field content &optional add)
2217   (save-excursion
2218     (save-restriction
2219       (let ((case-fold-search t)
2220             (inhibit-read-only t) ;; added by teranisi.
2221             beg)
2222         (std11-narrow-to-header mail-header-separator)
2223         (goto-char (point-min))
2224         (if (re-search-forward (concat "^" (regexp-quote field) ":") nil t)
2225             (if content
2226                 ;; replace field
2227                 (progn
2228                   (setq beg (point))
2229                   (re-search-forward "^[^ \t]" nil 'move)
2230                   (beginning-of-line)
2231                   (skip-chars-backward "\n")
2232                   (delete-region beg (point))
2233                   (insert " " content))
2234               ;; delete field
2235               (save-excursion
2236                 (beginning-of-line)
2237                 (setq beg (point)))
2238               (re-search-forward "^[^ \t]" nil 'move)
2239               (beginning-of-line)
2240               (delete-region beg (point)))
2241           (when (and add content)
2242             ;; add field
2243             (goto-char (point-max))
2244             (insert (concat field ": " content "\n"))))))))
2245
2246 (defun wl-draft-config-info-operation (msg operation)
2247   (let* ((msgdb-dir (elmo-folder-msgdb-path (wl-draft-get-folder)))
2248          (filename
2249           (expand-file-name
2250            (format "%s-%d" wl-draft-config-save-filename msg)
2251            msgdb-dir))
2252          element alist variable)
2253     (cond
2254      ((eq operation 'save)
2255       (let ((variables (elmo-uniq-list wl-draft-config-variables)))
2256         (while (setq variable (pop variables))
2257           (when (boundp variable)
2258             (wl-append alist
2259                        (list (cons variable (eval variable))))))
2260         (elmo-object-save filename alist)))
2261      ((eq operation 'load)
2262       (setq alist (elmo-object-load filename))
2263       (while (setq element (pop alist))
2264         (set (make-local-variable (car element)) (cdr element))
2265         (wl-append wl-draft-config-variables (list (car element)))))
2266      ((eq operation 'delete)
2267       (if (file-exists-p filename)
2268           (delete-file filename))))))
2269
2270 (defun wl-draft-queue-info-operation (msg operation
2271                                           &optional add-sent-message-via)
2272   (let* ((msgdb-dir (elmo-folder-msgdb-path
2273                      (wl-folder-get-elmo-folder wl-queue-folder)))
2274          (filename
2275           (expand-file-name
2276            (format "%s-%d" wl-draft-queue-save-filename msg)
2277            msgdb-dir))
2278          element alist variable)
2279     (cond
2280      ((eq operation 'save)
2281       (let ((variables (elmo-uniq-list
2282                         (append wl-draft-queue-save-variables
2283                                 wl-draft-config-variables
2284                                 (list 'wl-draft-fcc-list)))))
2285         (if add-sent-message-via
2286             (progn
2287               (push 'wl-sent-message-queued variables)
2288               (push 'wl-sent-message-via variables)))
2289         (while (setq variable (pop variables))
2290           (when (boundp variable)
2291             (wl-append alist
2292                        (list (cons variable (eval variable))))))
2293         (elmo-object-save filename alist)))
2294      ((eq operation 'load)
2295       (setq alist (elmo-object-load filename))
2296       (while (setq element (pop alist))
2297         (set (make-local-variable (car element)) (cdr element))))
2298      ((eq operation 'get-sent-via)
2299       (setq alist (elmo-object-load filename))
2300       (cdr (assq 'wl-sent-message-via alist)))
2301      ((eq operation 'delete)
2302       (if (file-exists-p filename)
2303           (delete-file filename))))))
2304
2305 (defun wl-draft-queue-append (wl-sent-message-via)
2306   (if wl-draft-verbose-send
2307       (message "Queuing..."))
2308   (let ((send-buffer (current-buffer))
2309         (folder (wl-folder-get-elmo-folder wl-queue-folder))
2310         (message-id (std11-field-body "Message-ID")))
2311     (if (elmo-folder-append-buffer folder)
2312         (progn
2313           (wl-draft-queue-info-operation
2314            (car (elmo-folder-status folder))
2315            'save wl-sent-message-via)
2316           (wl-draft-write-sendlog 'ok 'queue nil wl-queue-folder message-id)
2317           (when wl-draft-verbose-send
2318             (setq wl-draft-verbose-msg "Queuing...")
2319             (message "Queuing...done")))
2320       (wl-draft-write-sendlog 'failed 'queue nil wl-queue-folder message-id)
2321       (error "Queuing failed"))))
2322
2323 (defun wl-draft-queue-flush ()
2324   "Flush draft queue."
2325   (interactive)
2326   (let* ((queue-folder (wl-folder-get-elmo-folder wl-queue-folder))
2327          (msgs2 (progn
2328                   (elmo-folder-open-internal queue-folder)
2329                   (elmo-folder-list-messages queue-folder)))
2330          (i 0)
2331          (performed 0)
2332          (wl-draft-queue-flushing t)
2333          msgs failure len buffer msgid sent-via)
2334     ;; get plugged send message
2335     (while msgs2
2336       (setq sent-via (wl-draft-queue-info-operation (car msgs2) 'get-sent-via))
2337       (catch 'found
2338         (while sent-via
2339           (when (and (eq (nth 1 (car sent-via)) 'unplugged)
2340                      (or (not (nth 2 (car sent-via)))
2341                          (elmo-plugged-p
2342                           (car (nth 2 (car sent-via)))
2343                           (cdr (nth 2 (car sent-via))))))
2344             (wl-append msgs (list (car msgs2)))
2345             (throw 'found t))
2346           (setq sent-via (cdr sent-via))))
2347       (setq msgs2 (cdr msgs2)))
2348     (when (> (setq len (length msgs)) 0)
2349       (if (elmo-y-or-n-p (format
2350                           "%d message(s) are in the sending queue.  Send now? "
2351                           len)
2352                          (not elmo-dop-flush-confirm) t)
2353           (progn
2354             (save-excursion
2355               (setq buffer (get-buffer-create " *wl-draft-queue-flush*"))
2356               (set-buffer buffer)
2357               (while msgs
2358                 ;; reset buffer local variables
2359                 (kill-all-local-variables)
2360                 (erase-buffer)
2361                 (setq i (+ 1 i)
2362                       failure nil)
2363                 (setq wl-sent-message-via nil)
2364                 (wl-draft-queue-info-operation (car msgs) 'load)
2365                 (elmo-message-fetch queue-folder
2366                                     (car msgs)
2367                                     (elmo-make-fetch-strategy 'entire)
2368                                     nil (current-buffer))
2369                 (condition-case err
2370                     (setq failure (funcall
2371                                    wl-draft-queue-flush-send-function
2372                                    (format "Sending (%d/%d)..." i len)))
2373 ;;;               (wl-draft-raw-send nil nil
2374 ;;;                                  (format "Sending (%d/%d)..." i len))
2375                   (error
2376                    (elmo-display-error err t)
2377                    (setq failure t))
2378                   (quit
2379                    (setq failure t)))
2380                 (if (eq wl-sent-message-modified 'requeue)
2381                     (progn
2382                       (elmo-folder-delete-messages
2383                        queue-folder (cons (car msgs) nil))
2384                       (wl-draft-queue-info-operation (car msgs) 'delete))
2385                   (unless failure
2386                     (elmo-folder-delete-messages
2387                      queue-folder (cons (car msgs) nil))
2388                     (wl-draft-queue-info-operation (car msgs) 'delete)
2389                     (setq performed (+ 1 performed))))
2390                 (setq msgs (cdr msgs)))
2391               (kill-buffer buffer)
2392               (message "%d message(s) are sent." performed)))
2393         (message "%d message(s) are remained to be sent." len))
2394       (elmo-folder-close queue-folder)
2395       len)))
2396
2397 (defun wl-jump-to-draft-buffer (&optional arg)
2398   "Jump to the draft if exists."
2399   (interactive "P")
2400   (if arg
2401       (wl-jump-to-draft-folder)
2402     (let ((draft-bufs (wl-collect-draft))
2403           buf)
2404       (cond
2405        ((null draft-bufs)
2406         (message "No draft buffer exist."))
2407        (t
2408         (setq draft-bufs
2409               (sort (mapcar 'buffer-name draft-bufs)
2410                     (function (lambda (a b)
2411                                 (not (string< a b))))))
2412         (if (setq buf (cdr (member (buffer-name)
2413                                    draft-bufs)))
2414             (setq buf (car buf))
2415           (setq buf (car draft-bufs)))
2416         (switch-to-buffer buf))))))
2417
2418 (defun wl-jump-to-draft-folder ()
2419   (let ((msgs (reverse (elmo-folder-list-messages (wl-draft-get-folder))))
2420         (mybuf (buffer-name))
2421         msg buf)
2422     (if (not msgs)
2423         (message "No draft message exist.")
2424       (if (string-match (concat "^" wl-draft-folder "/") mybuf)
2425           (setq msg (cadr (memq
2426                            (string-to-int (substring mybuf (match-end 0)))
2427                            msgs))))
2428       (or msg (setq msg (car msgs)))
2429       (if (setq buf (get-buffer (format "%s/%d" wl-draft-folder msg)))
2430           (switch-to-buffer buf)
2431         (wl-draft-reedit msg)))))
2432
2433 (defun wl-draft-highlight-and-recenter (&optional n)
2434   (interactive "P")
2435   (when wl-highlight-body-too
2436     (let ((modified (buffer-modified-p)))
2437       (unwind-protect
2438           (progn
2439             (put-text-property (point-min) (point-max) 'face nil)
2440             (wl-highlight-message (point-min) (point-max) t))
2441         (set-buffer-modified-p modified))))
2442   (static-when (featurep 'xemacs)
2443     ;; Cope with one of many XEmacs bugs that `recenter' takes
2444     ;; a long time if there are a lot of invisible text lines.
2445     (redraw-frame))
2446   (recenter n))
2447
2448 ;; insert element from history
2449 (defvar wl-draft-current-history-position nil)
2450 (defvar wl-draft-history-backup-word "")
2451
2452 (defun wl-draft-previous-history-element (n)
2453   (interactive "p")
2454   (let (bol history beg end prev new)
2455     (when (and (not (wl-draft-on-field-p))
2456                (< (point)
2457                   (save-excursion
2458                     (goto-char (point-min))
2459                     (search-forward (concat "\n" mail-header-separator "\n") nil 0)
2460                     (point)))
2461                (save-excursion
2462                  (beginning-of-line)
2463                  (while (and (looking-at "^[ \t]")
2464                              (not (= (point) (point-min))))
2465                    (forward-line -1))
2466                  (cond
2467                   ((looking-at wl-folder-complete-header-regexp)
2468                    (and (boundp 'wl-read-folder-history)
2469                         (setq history wl-read-folder-history)))
2470                   ;; ((looking-at wl-address-complete-header-regexp)
2471                   ;;  (setq history .....))
2472                   (t
2473                    nil)))
2474                (eolp))
2475       (setq bol (save-excursion (beginning-of-line) (point)))
2476       (cond ((and (or (eq last-command 'wl-draft-previous-history-element)
2477                       (eq last-command 'wl-draft-next-history-element))
2478                   wl-draft-current-history-position)
2479              (setq end (point))
2480              (or (search-backward-regexp ",[ \t]*\\(.*\\)" bol t)
2481                  (search-backward-regexp "^[ \t]\\(.*\\)" bol t)
2482                  (search-backward-regexp "^[^ \t]*: \\(.*\\)" bol t))
2483              (setq prev (match-string 1))
2484              (goto-char (match-beginning 1))
2485              (setq beg (point))
2486              (if (cond ((< n 0)
2487                         (>= (+ n wl-draft-current-history-position) 0))
2488                        ((> n 0)
2489                         (<= (+ n wl-draft-current-history-position)
2490                             (length history))))
2491                  (progn
2492                    (setq wl-draft-current-history-position
2493                          (+ n wl-draft-current-history-position))
2494                    (setq new
2495                          (nth wl-draft-current-history-position
2496                               (append (list wl-draft-history-backup-word)
2497                                       history)))
2498                    (delete-region beg end)
2499                    (insert new))
2500                (goto-char end)
2501                (cond ((< n 0)
2502                       (message "End of history; no next item"))
2503                      ((> n 0)
2504                       (message "Beginning of history; no preceding item")))))
2505             ((and (> n 0)
2506                   (save-excursion
2507                     (or (search-backward-regexp ",[ \t]*\\(.*\\)" bol t)
2508                         (search-backward-regexp "^[ \t]\\(.*\\)" bol t)
2509                         (search-backward-regexp "^[^ \t]*: \\(.*\\)" bol t)))
2510                   (car history))
2511              (setq wl-draft-current-history-position 1)
2512              (setq wl-draft-history-backup-word (match-string 1))
2513              (delete-region (match-beginning 1) (match-end 1))
2514              (insert (car history)))
2515             (t
2516              (setq wl-draft-current-history-position nil))))))
2517
2518 (defun wl-draft-next-history-element (n)
2519   (interactive "p")
2520   (wl-draft-previous-history-element (- n)))
2521
2522 ;;;; user-agent support by Sen Nagata
2523
2524 ;; this appears to be necessarily global...
2525 (defvar wl-user-agent-compose-p nil)
2526 (defvar wl-user-agent-headers-and-body-alist nil)
2527
2528 ;; this should be a generic function for mail-mode -- i wish there was
2529 ;; something like it in sendmail.el
2530 (defun wl-user-agent-insert-header (header-name header-value)
2531   "Insert HEADER-NAME w/ value HEADER-VALUE into a message."
2532   ;; it seems like overriding existing headers is acceptable -- should
2533   ;; we provide an option?
2534
2535   ;; plan was: unfold header (might be folded), remove existing value, insert
2536   ;;           new value
2537   ;; wl doesn't seem to fold header lines yet anyway :-)
2538
2539   (let ((kill-whole-line t)
2540         end-of-line)
2541     (mail-position-on-field (capitalize header-name))
2542     (setq end-of-line (point))
2543     (beginning-of-line)
2544     (re-search-forward ":" end-of-line)
2545     (insert (concat " " header-value "\n"))
2546     (kill-line)))
2547
2548 ;; this should be a generic function for mail-mode -- i wish there was
2549 ;; something like it in sendmail.el
2550 ;;
2551 ;; ** haven't dealt w/ case where the body is already set **
2552 (defun wl-user-agent-insert-body (body-text)
2553   "Insert a body of text, BODY-TEXT, into a message."
2554   ;; code defensively... :-P
2555   (goto-char (point-min))
2556   (search-forward mail-header-separator)
2557   (forward-line 1)
2558   (insert body-text))
2559
2560 ;;;###autoload
2561 (defun wl-user-agent-compose (&optional to subject other-headers continue
2562                                         switch-function yank-action
2563                                         send-actions)
2564   "Support the `compose-mail' interface for wl.
2565 Only support for TO, SUBJECT, and OTHER-HEADERS has been implemented.
2566 Support for CONTINUE, YANK-ACTION, and SEND-ACTIONS has not
2567 been implemented yet.  Partial support for SWITCH-FUNCTION now supported."
2568
2569   (unless (featurep 'wl)
2570     (require 'wl))
2571   (or switch-function
2572       (setq switch-function 'keep))
2573   ;; protect these -- to and subject get bound at some point, so it looks
2574   ;; to be necessary to protect the values used w/in
2575   (let ((wl-user-agent-headers-and-body-alist other-headers)
2576         (wl-draft-use-frame (eq switch-function 'switch-to-buffer-other-frame))
2577         (wl-draft-buffer-style switch-function))
2578     (if to
2579         (if (wl-string-match-assoc "to" wl-user-agent-headers-and-body-alist
2580                                    'ignore-case)
2581             (setcdr
2582              (wl-string-match-assoc "to" wl-user-agent-headers-and-body-alist
2583                                     'ignore-case)
2584              to)
2585           (setq wl-user-agent-headers-and-body-alist
2586                 (cons (cons "to" to)
2587                       wl-user-agent-headers-and-body-alist))))
2588     (if subject
2589         (if (wl-string-match-assoc "subject"
2590                                    wl-user-agent-headers-and-body-alist
2591                                    'ignore-case)
2592             (setcdr
2593              (wl-string-match-assoc "subject"
2594                                     wl-user-agent-headers-and-body-alist
2595                                     'ignore-case)
2596              subject)
2597           (setq wl-user-agent-headers-and-body-alist
2598                 (cons (cons "subject" subject)
2599                       wl-user-agent-headers-and-body-alist))))
2600     ;; i think this is what we want to use...
2601     (unwind-protect
2602         (progn
2603           ;; tell the hook-function to do its stuff
2604           (setq wl-user-agent-compose-p t)
2605           ;; because to get the hooks working, wl-draft has to think it has
2606           ;; been called interactively
2607           (call-interactively 'wl-draft))
2608       (setq wl-user-agent-compose-p nil))))
2609
2610 (defun wl-user-agent-compose-internal ()
2611   "Manipulate headers and/or a body of a draft message."
2612   ;; being called from wl-user-agent-compose?
2613   (if wl-user-agent-compose-p
2614       (progn
2615         ;; insert headers
2616         (let ((headers wl-user-agent-headers-and-body-alist)
2617               (case-fold-search t))
2618           (while headers
2619             ;; skip body
2620             (if (not (string-match "^body$" (car (car headers))))
2621                 (wl-user-agent-insert-header
2622                  (car (car headers)) (cdr (car headers)))
2623               t)
2624             (setq headers (cdr headers))))
2625         ;; highlight headers (from wl-draft in wl-draft.el)
2626         (wl-highlight-headers 'for-draft)
2627         ;; insert body
2628         (if (wl-string-match-assoc "body" wl-user-agent-headers-and-body-alist
2629                                    'ignore-case)
2630             (wl-user-agent-insert-body
2631              (cdr (wl-string-match-assoc
2632                    "body"
2633                    wl-user-agent-headers-and-body-alist 'ignore-case)))))
2634     t))
2635
2636 (require 'product)
2637 (product-provide (provide 'wl-draft) (require 'wl-version))
2638
2639 ;;; wl-draft.el ends here