wl/wl-draft.el

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