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