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