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