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