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