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