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