code.delx.au - gnu-emacs/blob - lisp/mh-e/mh-comp.el

   1 ;;; mh-comp.el --- MH-E functions for composing messages
   2
   3 ;; Copyright (C) 1993, 95, 1997,
   4 ;;  2000, 01, 02, 03, 2004 Free Software Foundation, Inc.
   5
   6 ;; Author: Bill Wohler <wohler@newt.com>
   7 ;; Maintainer: Bill Wohler <wohler@newt.com>
   8 ;; Keywords: mail
   9 ;; See: mh-e.el
  10
  11 ;; This file is part of GNU Emacs.
  12
  13 ;; GNU Emacs is free software; you can redistribute it and/or modify
  14 ;; it under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation; either version 2, or (at your option)
  16 ;; any later version.
  17
  18 ;; GNU Emacs is distributed in the hope that it will be useful,
  19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;; GNU General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  25 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  26 ;; Boston, MA 02111-1307, USA.
  27
  28 ;;; Commentary:
  29
  30 ;; Internal support for MH-E package.
  31
  32 ;;; Change Log:
  33
  34 ;;; Code:
  35
  36 (require 'mh-e)
  37 (require 'gnus-util)
  38 (require 'easymenu)
  39 (require 'mh-utils)
  40 (mh-require-cl)
  41 (eval-when (compile load eval)
  42   (ignore-errors (require 'mailabbrev)))
  43
  44 ;; Shush the byte-compiler
  45 (defvar adaptive-fill-first-line-regexp)
  46 (defvar font-lock-defaults)
  47 (defvar mark-active)
  48 (defvar sendmail-coding-system)
  49 (defvar mh-identity-list)
  50 (defvar mh-identity-default)
  51 (defvar mh-identity-menu)
  52
  53 ;;; Autoloads
  54 (autoload 'Info-goto-node "info")
  55 (autoload 'mail-mode-fill-paragraph "sendmail")
  56 (autoload 'mm-handle-displayed-p "mm-decode")
  57
  58 (autoload 'sc-cite-original "sc"
  59   "Workhorse citing function which performs the initial citation.
  60 This is callable from the various mail and news readers' reply
  61 function according to the agreed upon standard.  See `\\[sc-describe]'
  62 for more details.  `sc-cite-original' does not do any yanking of the
  63 original message but it does require a few things:
  64
  65      1) The reply buffer is the current buffer.
  66
  67      2) The original message has been yanked and inserted into the
  68         reply buffer.
  69
  70      3) Verbose mail headers from the original message have been
  71         inserted into the reply buffer directly before the text of the
  72         original message.
  73
  74      4) Point is at the beginning of the verbose headers.
  75
  76      5) Mark is at the end of the body of text to be cited.
  77
  78 For Emacs 19's, the region need not be active (and typically isn't
  79 when this function is called.  Also, the hook `sc-pre-hook' is run
  80 before, and `sc-post-hook' is run after the guts of this function.")
  81
  82 ;;; Site customization (see also mh-utils.el):
  83
  84 (defvar mh-send-prog "send"
  85   "Name of the MH send program.
  86 Some sites need to change this because of a name conflict.")
  87
  88 (defvar mh-redist-full-contents nil
  89   "Non-nil if the `dist' command needs whole letter for redistribution.
  90 This is the case only when `send' is compiled with the BERK option.
  91 If MH will not allow you to redist a previously redist'd msg, set to nil.")
  92
  93 (defvar mh-redist-background nil
  94   "If non-nil redist will be done in background like send.
  95 This allows transaction log to be visible if -watch, -verbose or -snoop are
  96 used.")
  97
  98 (defvar mh-note-repl "-"
  99   "String whose first character is used to notate replied to messages.")
 100
 101 (defvar mh-note-forw "F"
 102   "String whose first character is used to notate forwarded messages.")
 103
 104 (defvar mh-note-dist "R"
 105   "String whose first character is used to notate redistributed messages.")
 106
 107 (defvar mh-yank-hooks nil
 108   "Obsolete hook for modifying a citation just inserted in the mail buffer.
 109 Each hook function can find the citation between point and mark.
 110 And each hook function should leave point and mark around the citation
 111 text as modified.
 112
 113 This is a normal hook, misnamed for historical reasons.
 114 It is semi-obsolete and is only used if `mail-citation-hook' is nil.")
 115
 116 (defvar mail-citation-hook nil
 117   "*Hook for modifying a citation just inserted in the mail buffer.
 118 Each hook function can find the citation between point and mark.
 119 And each hook function should leave point and mark around the citation
 120 text as modified.
 121
 122 If this hook is entirely empty (nil), the text of the message is inserted
 123 with `mh-ins-buf-prefix' prefixed to each line.
 124
 125 See also the variable `mh-yank-from-start-of-msg', which controls how
 126 much of the message passed to the hook.
 127
 128 This hook was historically provided to set up supercite.  You may now leave
 129 this nil and set up supercite by setting the variable
 130 `mh-yank-from-start-of-msg' to 'supercite or, for more automatic insertion,
 131 to 'autosupercite.")
 132
 133 (defvar mh-comp-formfile "components"
 134   "Name of file to be used as a skeleton for composing messages.
 135 Default is \"components\".  If not an absolute file name, the file
 136 is searched for first in the user's MH directory, then in the
 137 system MH lib directory.")
 138
 139 (defvar mh-repl-formfile "replcomps"
 140   "Name of file to be used as a skeleton for replying to messages.
 141 Default is \"replcomps\".  If not an absolute file name, the file
 142 is searched for first in the user's MH directory, then in the
 143 system MH lib directory.")
 144
 145 (defvar mh-repl-group-formfile "replgroupcomps"
 146   "Name of file to be used as a skeleton for replying to messages.
 147 This file is used to form replies to the sender and all recipients of a
 148 message. Only used if `mh-nmh-flag' is non-nil. Default is \"replgroupcomps\".
 149 If not an absolute file name, the file is searched for first in the user's MH
 150 directory, then in the system MH lib directory.")
 151
 152 (defvar mh-rejected-letter-start
 153   (format "^%s$"
 154           (regexp-opt
 155            '("Content-Type: message/rfc822" ;MIME MDN
 156              "   ----- Unsent message follows -----" ;from sendmail V5
 157              " --------Unsent Message below:" ; from sendmail at BU
 158              "   ----- Original message follows -----" ;from sendmail V8
 159              "------- Unsent Draft"     ;from MH itself
 160              "----------  Original Message  ----------" ;from zmailer
 161              "  --- The unsent message follows ---" ;from AIX mail system
 162              "    Your message follows:" ;from MMDF-II
 163              "Content-Description: Returned Content" ;1993 KJ sendmail
 164              ))))
 165
 166 (defvar mh-new-draft-cleaned-headers
 167   "^Date:\\|^Received:\\|^Message-Id:\\|^From:\\|^Sender:\\|^Errors-To:\\|^Delivery-Date:\\|^Return-Path:"
 168   "Regexp of header lines to remove before offering a message as a new draft.
 169 Used by the \\<mh-folder-mode-map>`\\[mh-edit-again]' and `\\[mh-extract-rejected-mail]' commands.")
 170
 171 (defvar mh-to-field-choices '(("t" . "To:") ("s" . "Subject:") ("c" . "Cc:")
 172                               ("b" . "Bcc:") ("f" . "Fcc:") ("r" . "From:")
 173                               ("d" . "Dcc:"))
 174   "Alist of (final-character . field-name) choices for `mh-to-field'.")
 175
 176 (defvar mh-letter-mode-map (copy-keymap text-mode-map)
 177   "Keymap for composing mail.")
 178
 179 (defvar mh-letter-mode-syntax-table nil
 180   "Syntax table used by MH-E while in MH-Letter mode.")
 181
 182 (if mh-letter-mode-syntax-table
 183     ()
 184   (setq mh-letter-mode-syntax-table
 185         (make-syntax-table text-mode-syntax-table))
 186   (modify-syntax-entry ?% "." mh-letter-mode-syntax-table))
 187
 188 (defvar mh-sent-from-folder nil
 189   "Folder of msg assoc with this letter.")
 190
 191 (defvar mh-sent-from-msg nil
 192   "Number of msg assoc with this letter.")
 193
 194 (defvar mh-send-args nil
 195   "Extra args to pass to \"send\" command.")
 196
 197 (defvar mh-annotate-char nil
 198   "Character to use to annotate `mh-sent-from-msg'.")
 199
 200 (defvar mh-annotate-field nil
 201   "Field name for message annotation.")
 202
 203 (defvar mh-insert-auto-fields-done-local nil
 204   "Buffer-local variable set when `mh-insert-auto-fields' successfully called.")
 205 (make-variable-buffer-local 'mh-insert-auto-fields-done-local)
 206
 207 ;;;###autoload
 208 (defun mh-smail ()
 209   "Compose and send mail with the MH mail system.
 210 This function is an entry point to MH-E, the Emacs front end
 211 to the MH mail system.
 212
 213 See documentation of `\\[mh-send]' for more details on composing mail."
 214   (interactive)
 215   (mh-find-path)
 216   (call-interactively 'mh-send))
 217
 218 (defvar mh-error-if-no-draft nil)       ;raise error over using old draft
 219
 220 ;;;###autoload
 221 (defun mh-smail-batch (&optional to subject other-headers &rest ignored)
 222   "Set up a mail composition draft with the MH mail system.
 223 This function is an entry point to MH-E, the Emacs front end
 224 to the MH mail system.  This function does not prompt the user
 225 for any header fields, and thus is suitable for use by programs
 226 that want to create a mail buffer.
 227 Users should use `\\[mh-smail]' to compose mail.
 228 Optional arguments for setting certain fields include TO, SUBJECT, and
 229 OTHER-HEADERS. Additional arguments are IGNORED."
 230   (mh-find-path)
 231   (let ((mh-error-if-no-draft t))
 232     (mh-send (or to "") "" (or subject ""))))
 233
 234 ;; XEmacs needs this:
 235 ;;;###autoload
 236 (defun mh-user-agent-compose (&optional to subject other-headers continue
 237                                         switch-function yank-action
 238                                         send-actions)
 239   "Set up mail composition draft with the MH mail system.
 240 This is `mail-user-agent' entry point to MH-E.
 241
 242 The optional arguments TO and SUBJECT specify recipients and the
 243 initial Subject field, respectively.
 244
 245 OTHER-HEADERS is an alist specifying additional
 246 header fields.  Elements look like (HEADER . VALUE) where both
 247 HEADER and VALUE are strings.
 248
 249 CONTINUE, SWITCH-FUNCTION, YANK-ACTION and SEND-ACTIONS are ignored."
 250   (mh-find-path)
 251   (let ((mh-error-if-no-draft t))
 252     (mh-send to "" subject)
 253     (while other-headers
 254       (mh-insert-fields (concat (car (car other-headers)) ":")
 255                         (cdr (car other-headers)))
 256       (setq other-headers (cdr other-headers)))))
 257
 258 ;;;###mh-autoload
 259 (defun mh-edit-again (msg)
 260   "Clean up a draft or a message MSG previously sent and make it resendable.
 261 Default is the current message.
 262 The variable `mh-new-draft-cleaned-headers' specifies the headers to remove.
 263 See also documentation for `\\[mh-send]' function."
 264   (interactive (list (mh-get-msg-num t)))
 265   (let* ((from-folder mh-current-folder)
 266          (config (current-window-configuration))
 267          (draft
 268           (cond ((and mh-draft-folder (equal from-folder mh-draft-folder))
 269                  (pop-to-buffer (find-file-noselect (mh-msg-filename msg)) t)
 270                  (rename-buffer (format "draft-%d" msg))
 271                  ;; Make buffer writable...
 272                  (setq buffer-read-only nil)
 273                  ;; If buffer was being used to display the message reinsert
 274                  ;; from file...
 275                  (when (eq major-mode 'mh-show-mode)
 276                    (erase-buffer)
 277                    (insert-file-contents buffer-file-name))
 278                  (buffer-name))
 279                 (t
 280                  (mh-read-draft "clean-up" (mh-msg-filename msg) nil)))))
 281     (mh-clean-msg-header (point-min) mh-new-draft-cleaned-headers nil)
 282     (mh-insert-header-separator)
 283     (goto-char (point-min))
 284     (save-buffer)
 285     (mh-compose-and-send-mail draft "" from-folder nil nil nil nil nil nil
 286                               config)
 287     (mh-letter-mode-message)
 288     (mh-letter-adjust-point)))
 289
 290 ;;;###mh-autoload
 291 (defun mh-extract-rejected-mail (msg)
 292   "Extract message MSG returned by the mail system and make it resendable.
 293 Default is the current message.  The variable `mh-new-draft-cleaned-headers'
 294 gives the headers to clean out of the original message.
 295 See also documentation for `\\[mh-send]' function."
 296   (interactive (list (mh-get-msg-num t)))
 297   (let ((from-folder mh-current-folder)
 298         (config (current-window-configuration))
 299         (draft (mh-read-draft "extraction" (mh-msg-filename msg) nil)))
 300     (goto-char (point-min))
 301     (cond ((re-search-forward mh-rejected-letter-start nil t)
 302            (skip-chars-forward " \t\n")
 303            (delete-region (point-min) (point))
 304            (mh-clean-msg-header (point-min) mh-new-draft-cleaned-headers nil))
 305           (t
 306            (message "Does not appear to be a rejected letter.")))
 307     (mh-insert-header-separator)
 308     (goto-char (point-min))
 309     (save-buffer)
 310     (mh-compose-and-send-mail draft "" from-folder msg
 311                               (mh-get-header-field "To:")
 312                               (mh-get-header-field "From:")
 313                               (mh-get-header-field "Cc:")
 314                               nil nil config)
 315     (mh-letter-mode-message)))
 316
 317 ;;;###mh-autoload
 318 (defun mh-forward (to cc &optional range)
 319   "Forward messages to the recipients TO and CC.
 320 Use optional RANGE argument to specify a message or sequence to forward.
 321 Default is the displayed message.
 322
 323 Check the documentation of `mh-interactive-range' to see how RANGE is read in
 324 interactive use.
 325
 326 See also documentation for `\\[mh-send]' function."
 327   (interactive (list (mh-interactive-read-address "To: ")
 328                      (mh-interactive-read-address "Cc: ")
 329                      (mh-interactive-range "Forward")))
 330   (let* ((folder mh-current-folder)
 331          (msgs (mh-range-to-msg-list range))
 332          (config (current-window-configuration))
 333          (fwd-msg-file (mh-msg-filename (car msgs) folder))
 334          ;; forw always leaves file in "draft" since it doesn't have -draft
 335          (draft-name (expand-file-name "draft" mh-user-path))
 336          (draft (cond ((or (not (file-exists-p draft-name))
 337                            (y-or-n-p "The file 'draft' exists.  Discard it? "))
 338                        (mh-exec-cmd "forw" "-build" (if mh-nmh-flag "-mime")
 339                                     mh-current-folder
 340                                     (mh-coalesce-msg-list msgs))
 341                        (prog1
 342                            (mh-read-draft "" draft-name t)
 343                          (mh-insert-fields "To:" to "Cc:" cc)
 344                          (save-buffer)))
 345                       (t
 346                        (mh-read-draft "" draft-name nil)))))
 347     (let (orig-from
 348           orig-subject)
 349       (save-excursion
 350         (set-buffer (get-buffer-create mh-temp-buffer))
 351         (erase-buffer)
 352         (insert-file-contents fwd-msg-file)
 353         (setq orig-from (mh-get-header-field "From:"))
 354         (setq orig-subject (mh-get-header-field "Subject:")))
 355       (let ((forw-subject
 356              (mh-forwarded-letter-subject orig-from orig-subject)))
 357         (mh-insert-fields "Subject:" forw-subject)
 358         (goto-char (point-min))
 359         ;; If using MML, translate mhn
 360         (if (equal mh-compose-insertion 'gnus)
 361             (save-excursion
 362               (goto-char (mh-mail-header-end))
 363               (while
 364                   (re-search-forward
 365                    "^#forw \\[\\([^]]+\\)\\] \\(+\\S-+\\) \\(.*\\)$"
 366                    (point-max) t)
 367                 (let ((description (if (equal (match-string 1)
 368                                               "forwarded messages")
 369                                        "forwarded message %d"
 370                                      (match-string 1)))
 371                       (msgs (split-string (match-string 3)))
 372                       (i 0))
 373                   (beginning-of-line)
 374                   (delete-region (point) (progn (forward-line 1) (point)))
 375                   (dolist (msg msgs)
 376                     (setq i (1+ i))
 377                     (mh-mml-forward-message (format description i)
 378                                             folder msg))))))
 379         ;; Postition just before forwarded message
 380         (if (re-search-forward "^------- Forwarded Message" nil t)
 381             (forward-line -1)
 382           (goto-char (mh-mail-header-end))
 383           (forward-line 1))
 384         (delete-other-windows)
 385         (mh-add-msgs-to-seq msgs 'forwarded t)
 386         (mh-compose-and-send-mail draft "" folder msgs
 387                                   to forw-subject cc
 388                                   mh-note-forw "Forwarded:"
 389                                   config)
 390         (mh-letter-mode-message)
 391         (mh-letter-adjust-point)))))
 392
 393 (defun mh-forwarded-letter-subject (from subject)
 394   "Return a Subject suitable for a forwarded message.
 395 Original message has headers FROM and SUBJECT."
 396   (let ((addr-start (string-match "<" from))
 397         (comment (string-match "(" from)))
 398     (cond ((and addr-start (> addr-start 0))
 399            ;; Full Name <luser@host>
 400            (setq from (substring from 0 (1- addr-start))))
 401           (comment
 402            ;; luser@host (Full Name)
 403            (setq from (substring from (1+ comment) (1- (length from)))))))
 404   (format mh-forward-subject-format from subject))
 405
 406 ;;;###autoload
 407 (defun mh-smail-other-window ()
 408   "Compose and send mail in other window with the MH mail system.
 409 This function is an entry point to MH-E, the Emacs front end
 410 to the MH mail system.
 411
 412 See documentation of `\\[mh-send]' for more details on composing mail."
 413   (interactive)
 414   (mh-find-path)
 415   (call-interactively 'mh-send-other-window))
 416
 417 ;;;###mh-autoload
 418 (defun mh-redistribute (to cc &optional msg)
 419   "Redistribute displayed message to recipients TO and CC.
 420 Use optional argument MSG to redistribute another message.
 421 Depending on how your copy of MH was compiled, you may need to change the
 422 setting of the variable `mh-redist-full-contents'.  See its documentation."
 423   (interactive (list (mh-read-address "Redist-To: ")
 424                      (mh-read-address "Redist-Cc: ")
 425                      (mh-get-msg-num t)))
 426   (or msg
 427       (setq msg (mh-get-msg-num t)))
 428   (save-window-excursion
 429     (let ((folder mh-current-folder)
 430           (draft (mh-read-draft "redistribution"
 431                                 (if mh-redist-full-contents
 432                                     (mh-msg-filename msg)
 433                                   nil)
 434                                 nil)))
 435       (mh-goto-header-end 0)
 436       (insert "Resent-To: " to "\n")
 437       (if (not (equal cc "")) (insert "Resent-cc: " cc "\n"))
 438       (mh-clean-msg-header
 439        (point-min)
 440        "^Message-Id:\\|^Received:\\|^Return-Path:\\|^Sender:\\|^Date:\\|^From:"
 441        nil)
 442       (save-buffer)
 443       (message "Redistributing...")
 444       (let ((env "mhdist=1"))
 445         ;; Setup environment...
 446         (setq env (concat env " mhaltmsg=" (if mh-redist-full-contents
 447                                                buffer-file-name
 448                                              (mh-msg-filename msg folder))))
 449         (unless mh-redist-full-contents
 450           (setq env (concat env " mhannotate=1")))
 451         ;; Redistribute...
 452         (if mh-redist-background
 453             (mh-exec-cmd-env-daemon env mh-send-prog nil buffer-file-name)
 454           (mh-exec-cmd-error env mh-send-prog "-push" buffer-file-name))
 455         ;; Annotate...
 456         (mh-annotate-msg msg folder mh-note-dist
 457                          "-component" "Resent:"
 458                          "-text" (format "\"%s %s\"" to cc)))
 459       (kill-buffer draft)
 460       (message "Redistributing...done"))))
 461
 462 (defun mh-show-buffer-message-number (&optional buffer)
 463   "Message number of displayed message in corresponding show buffer.
 464 Return nil if show buffer not displayed.
 465 If in `mh-letter-mode', don't display the message number being replied to,
 466 but rather the message number of the show buffer associated with our
 467 originating folder buffer.
 468 Optional argument BUFFER can be used to specify the buffer."
 469   (save-excursion
 470     (if buffer
 471         (set-buffer buffer))
 472     (cond ((eq major-mode 'mh-show-mode)
 473            (let ((number-start (mh-search-from-end ?/ buffer-file-name)))
 474              (car (read-from-string (substring buffer-file-name
 475                                                (1+ number-start))))))
 476           ((and (eq major-mode 'mh-folder-mode)
 477                 mh-show-buffer
 478                 (get-buffer mh-show-buffer))
 479            (mh-show-buffer-message-number mh-show-buffer))
 480           ((and (eq major-mode 'mh-letter-mode)
 481                 mh-sent-from-folder
 482                 (get-buffer mh-sent-from-folder))
 483            (mh-show-buffer-message-number mh-sent-from-folder))
 484           (t
 485            nil))))
 486
 487 ;;;###mh-autoload
 488 (defun mh-reply (message &optional reply-to includep)
 489   "Reply to MESSAGE.
 490 Default is the displayed message.
 491 If the optional argument REPLY-TO is not given, prompts for type of addresses
 492 to reply to:
 493    from    sender only,
 494    to      sender and primary recipients,
 495    cc/all  sender and all recipients.
 496 If optional prefix argument INCLUDEP provided, then include the message
 497 in the reply using filter `mhl.reply' in your MH directory.
 498 If the file named by `mh-repl-formfile' exists, it is used as a skeleton
 499 for the reply.  See also documentation for `\\[mh-send]' function."
 500   (interactive (list
 501                 (mh-get-msg-num t)
 502                 (let ((minibuffer-help-form
 503                        "from => Sender only\nto => Sender and primary recipients\ncc or all => Sender and all recipients"))
 504                   (or mh-reply-default-reply-to
 505                       (completing-read "Reply to whom? (from, to, all) [from]: "
 506                                        '(("from") ("to") ("cc") ("all"))
 507                                        nil
 508                                        t)))
 509                 current-prefix-arg))
 510   (let* ((folder mh-current-folder)
 511          (show-buffer mh-show-buffer)
 512          (config (current-window-configuration))
 513          (group-reply (or (equal reply-to "cc") (equal reply-to "all")))
 514          (form-file (cond ((and mh-nmh-flag group-reply
 515                                 (stringp mh-repl-group-formfile))
 516                            mh-repl-group-formfile)
 517                           ((stringp mh-repl-formfile) mh-repl-formfile)
 518                           (t nil))))
 519     (message "Composing a reply...")
 520     (mh-exec-cmd "repl" "-build" "-noquery" "-nodraftfolder"
 521                  (if form-file
 522                      (list "-form" form-file))
 523                  mh-current-folder message
 524                  (cond ((or (equal reply-to "from") (equal reply-to ""))
 525                         '("-nocc" "all"))
 526                        ((equal reply-to "to")
 527                         '("-cc" "to"))
 528                        (group-reply (if mh-nmh-flag
 529                                         '("-group" "-nocc" "me")
 530                                       '("-cc" "all" "-nocc" "me"))))
 531                  (cond ((or (eq mh-yank-from-start-of-msg 'autosupercite)
 532                             (eq mh-yank-from-start-of-msg 'autoattrib))
 533                         '("-noformat"))
 534                        (includep '("-filter" "mhl.reply"))
 535                        (t '())))
 536     (let ((draft (mh-read-draft "reply"
 537                                 (expand-file-name "reply" mh-user-path)
 538                                 t)))
 539       (delete-other-windows)
 540       (save-buffer)
 541
 542       (let ((to (mh-get-header-field "To:"))
 543             (subject (mh-get-header-field "Subject:"))
 544             (cc (mh-get-header-field "Cc:")))
 545         (goto-char (point-min))
 546         (mh-goto-header-end 1)
 547         (or includep
 548             (not mh-reply-show-message-flag)
 549             (mh-in-show-buffer (show-buffer)
 550               (mh-display-msg message folder)))
 551         (mh-add-msgs-to-seq message 'answered t)
 552         (message "Composing a reply...done")
 553         (mh-compose-and-send-mail draft "" folder message to subject cc
 554                                   mh-note-repl "Replied:" config))
 555       (when (and (or (eq 'autosupercite mh-yank-from-start-of-msg)
 556                      (eq 'autoattrib mh-yank-from-start-of-msg))
 557                  (eq (mh-show-buffer-message-number) mh-sent-from-msg))
 558         (undo-boundary)
 559         (mh-yank-cur-msg))
 560       (mh-letter-mode-message))))
 561
 562 ;;;###mh-autoload
 563 (defun mh-send (to cc subject)
 564   "Compose and send a letter.
 565
 566 Do not call this function from outside MH-E; use \\[mh-smail] instead.
 567
 568 The file named by `mh-comp-formfile' will be used as the form.
 569 The letter is composed in `mh-letter-mode'; see its documentation for more
 570 details.
 571 If `mh-compose-letter-function' is defined, it is called on the draft and
 572 passed three arguments: TO, CC, and SUBJECT."
 573   (interactive (list
 574                 (mh-interactive-read-address "To: ")
 575                 (mh-interactive-read-address "Cc: ")
 576                 (mh-interactive-read-string "Subject: ")))
 577   (let ((config (current-window-configuration)))
 578     (delete-other-windows)
 579     (mh-send-sub to cc subject config)))
 580
 581 ;;;###mh-autoload
 582 (defun mh-send-other-window (to cc subject)
 583   "Compose and send a letter in another window.
 584
 585 Do not call this function from outside MH-E; use \\[mh-smail-other-window]
 586 instead.
 587
 588 The file named by `mh-comp-formfile' will be used as the form.
 589 The letter is composed in `mh-letter-mode'; see its documentation for more
 590 details.
 591 If `mh-compose-letter-function' is defined, it is called on the draft and
 592 passed three arguments: TO, CC, and SUBJECT."
 593   (interactive (list
 594                 (mh-interactive-read-address "To: ")
 595                 (mh-interactive-read-address "Cc: ")
 596                 (mh-interactive-read-string "Subject: ")))
 597   (let ((pop-up-windows t))
 598     (mh-send-sub to cc subject (current-window-configuration))))
 599
 600 (defun mh-send-sub (to cc subject config)
 601   "Do the real work of composing and sending a letter.
 602 Expects the TO, CC, and SUBJECT fields as arguments.
 603 CONFIG is the window configuration before sending mail."
 604   (let ((folder mh-current-folder)
 605         (msg-num (mh-get-msg-num nil)))
 606     (message "Composing a message...")
 607     (let ((draft (mh-read-draft
 608                   "message"
 609                   (let (components)
 610                     (cond
 611                      ((file-exists-p
 612                        (setq components
 613                              (expand-file-name mh-comp-formfile mh-user-path)))
 614                       components)
 615                      ((file-exists-p
 616                        (setq components
 617                              (expand-file-name mh-comp-formfile mh-lib)))
 618                       components)
 619                      ((file-exists-p
 620                        (setq components
 621                              (expand-file-name mh-comp-formfile
 622                                                ;; What is this mh-etc ??  -sm
 623                                                ;; This is dead code, so
 624                                                ;; remove it.
 625                                         ;(and (boundp 'mh-etc) mh-etc)
 626                                                )))
 627                       components)
 628                      (t
 629                       (error (format "Can't find components file \"%s\""
 630                                      components)))))
 631                   nil)))
 632       (mh-insert-fields "To:" to "Subject:" subject "Cc:" cc)
 633       (goto-char (point-max))
 634       (mh-compose-and-send-mail draft "" folder msg-num
 635                                 to subject cc
 636                                 nil nil config)
 637       (mh-letter-mode-message)
 638       (mh-letter-adjust-point))))
 639
 640 (defun mh-read-draft (use initial-contents delete-contents-file)
 641   "Read draft file into a draft buffer and make that buffer the current one.
 642 USE is a message used for prompting about the intended use of the message.
 643 INITIAL-CONTENTS is filename that is read into an empty buffer, or nil
 644 if buffer should not be modified.  Delete the initial-contents file if
 645 DELETE-CONTENTS-FILE flag is set.
 646 Returns the draft folder's name.
 647 If the draft folder facility is enabled in ~/.mh_profile, a new buffer is
 648 used each time and saved in the draft folder.  The draft file can then be
 649 reused."
 650   (cond (mh-draft-folder
 651          (let ((orig-default-dir default-directory)
 652                (draft-file-name (mh-new-draft-name)))
 653            (pop-to-buffer (generate-new-buffer
 654                            (format "draft-%s"
 655                                    (file-name-nondirectory draft-file-name))))
 656            (condition-case ()
 657                (insert-file-contents draft-file-name t)
 658              (file-error))
 659            (setq default-directory orig-default-dir)))
 660         (t
 661          (let ((draft-name (expand-file-name "draft" mh-user-path)))
 662            (pop-to-buffer "draft")      ; Create if necessary
 663            (if (buffer-modified-p)
 664                (if (y-or-n-p "Draft has been modified; kill anyway? ")
 665                    (set-buffer-modified-p nil)
 666                  (error "Draft preserved")))
 667            (setq buffer-file-name draft-name)
 668            (clear-visited-file-modtime)
 669            (unlock-buffer)
 670            (cond ((and (file-exists-p draft-name)
 671                        (not (equal draft-name initial-contents)))
 672                   (insert-file-contents draft-name)
 673                   (delete-file draft-name))))))
 674   (cond ((and initial-contents
 675               (or (zerop (buffer-size))
 676                   (if (y-or-n-p
 677                        (format "A draft exists.  Use for %s? " use))
 678                       (if mh-error-if-no-draft
 679                           (error "A prior draft exists"))
 680                     t)))
 681          (erase-buffer)
 682          (insert-file-contents initial-contents)
 683          (if delete-contents-file (delete-file initial-contents))))
 684   (auto-save-mode 1)
 685   (if mh-draft-folder
 686       (save-buffer))                    ; Do not reuse draft name
 687   (buffer-name))
 688
 689 (defun mh-new-draft-name ()
 690   "Return the pathname of folder for draft messages."
 691   (save-excursion
 692     (mh-exec-cmd-quiet t "mhpath" mh-draft-folder "new")
 693     (buffer-substring (point-min) (1- (point-max)))))
 694
 695 (defun mh-annotate-msg (msg buffer note &rest args)
 696   "Mark MSG in BUFFER with character NOTE and annotate message with ARGS.
 697 MSG can be a message number, a list of message numbers, or a sequence."
 698   (apply 'mh-exec-cmd "anno" buffer
 699          (if (listp msg) (append msg args) (cons msg args)))
 700   (save-excursion
 701     (cond ((get-buffer buffer)          ; Buffer may be deleted
 702            (set-buffer buffer)
 703            (mh-iterate-on-range nil msg
 704              (mh-notate nil note (1+ mh-cmd-note)))))))
 705
 706 (defun mh-insert-fields (&rest name-values)
 707   "Insert the NAME-VALUES pairs in the current buffer.
 708 If the field exists, append the value to it.
 709 Do not insert any pairs whose value is the empty string."
 710   (let ((case-fold-search t))
 711     (while name-values
 712       (let ((field-name (car name-values))
 713             (value (car (cdr name-values))))
 714         (cond ((equal value "")
 715                nil)
 716               ((mh-position-on-field field-name)
 717                (insert " " (or value "")))
 718               (t
 719                (insert field-name " " value "\n")))
 720         (setq name-values (cdr (cdr name-values)))))))
 721
 722 (defun mh-position-on-field (field &optional ignored)
 723   "Move to the end of the FIELD in the header.
 724 Move to end of entire header if FIELD not found.
 725 Returns non-nil iff FIELD was found.
 726 The optional second arg is for pre-version 4 compatibility and is IGNORED."
 727   (cond ((mh-goto-header-field field)
 728          (mh-header-field-end)
 729          t)
 730         ((mh-goto-header-end 0)
 731          nil)))
 732
 733 (defun mh-get-header-field (field)
 734   "Find and return the body of FIELD in the mail header.
 735 Returns the empty string if the field is not in the header of the
 736 current buffer."
 737   (if (mh-goto-header-field field)
 738       (progn
 739         (skip-chars-forward " \t")      ;strip leading white space in body
 740         (let ((start (point)))
 741           (mh-header-field-end)
 742           (buffer-substring-no-properties start (point))))
 743     ""))
 744
 745 (fset 'mh-get-field 'mh-get-header-field) ;MH-E 4 compatibility
 746
 747 (defun mh-goto-header-field (field)
 748   "Move to FIELD in the message header.
 749 Move to the end of the FIELD name, which should end in a colon.
 750 Returns t if found, nil if not."
 751   (goto-char (point-min))
 752   (let ((case-fold-search t)
 753         (headers-end (save-excursion
 754                        (mh-goto-header-end 0)
 755                        (point))))
 756     (re-search-forward (format "^%s" field) headers-end t)))
 757
 758 (defun mh-goto-header-end (arg)
 759   "Move the cursor ARG lines after the header."
 760   (if (re-search-forward "^-*$" nil nil)
 761       (forward-line arg)))
 762
 763 (defun mh-extract-from-header-value ()
 764   "Extract From: string from header."
 765   (save-excursion
 766     (if (not (mh-goto-header-field "From:"))
 767         nil
 768       (skip-chars-forward " \t")
 769       (buffer-substring-no-properties
 770        (point) (progn (mh-header-field-end)(point))))))
 771
 772 \f
 773
 774 ;;; Mode for composing and sending a draft message.
 775
 776 (put 'mh-letter-mode 'mode-class 'special)
 777
 778 ;;; Menu extracted from mh-menubar.el V1.1 (31 July 2001)
 779 (eval-when-compile (defvar mh-letter-menu nil))
 780 (cond
 781  ((fboundp 'easy-menu-define)
 782   (easy-menu-define
 783     mh-letter-menu mh-letter-mode-map "Menu for MH-E letter mode."
 784     '("Letter"
 785       ["Send This Draft"          mh-send-letter t]
 786       ["Split Current Line"       mh-open-line t]
 787       ["Check Recipient"          mh-check-whom t]
 788       ["Yank Current Message"     mh-yank-cur-msg t]
 789       ["Insert a Message..."      mh-insert-letter t]
 790       ["Insert Signature"         mh-insert-signature t]
 791       ["GPG Sign message"
 792        mh-mml-secure-message-sign-pgpmime mh-gnus-pgp-support-flag]
 793       ["GPG Encrypt message"
 794        mh-mml-secure-message-encrypt-pgpmime mh-gnus-pgp-support-flag]
 795       ["Compose Insertion (MIME)..."      mh-compose-insertion t]
 796       ;;    ["Compose Compressed tar (MIME)..."
 797       ;;mh-mhn-compose-external-compressed-tar t]
 798       ;;    ["Compose Anon FTP (MIME)..."       mh-mhn-compose-anon-ftp t]
 799       ["Compose Forward (MIME)..."        mh-compose-forward t]
 800       ;; The next two will have to be merged. But I also need to make sure the
 801       ;; user can't mix directives of both types.
 802       ["Pull in All Compositions (mhn)"
 803        mh-edit-mhn (mh-mhn-directive-present-p)]
 804       ["Pull in All Compositions (gnus)"
 805        mh-mml-to-mime (mh-mml-directive-present-p)]
 806       ["Revert to Non-MIME Edit (mhn)"
 807        mh-revert-mhn-edit (equal mh-compose-insertion 'mhn)]
 808       ["Kill This Draft"          mh-fully-kill-draft t]))))
 809
 810 ;;; Help Messages
 811 ;;; Group messages logically, more or less.
 812 (defvar mh-letter-mode-help-messages
 813   '((nil
 814      "Send letter:          \\[mh-send-letter]"
 815      "\t\tOpen line:            \\[mh-open-line]\n"
 816      "Kill letter:          \\[mh-fully-kill-draft]"
 817      "\t\tInsert:\n"
 818      "Check recipients:     \\[mh-check-whom]"
 819      "\t\t  Current message:    \\[mh-yank-cur-msg]\n"
 820      "Encrypt message:      \\[mh-mml-secure-message-encrypt-pgpmime]"
 821      "\t\t  Attachment:         \\[mh-compose-insertion]\n"
 822      "Sign message:         \\[mh-mml-secure-message-sign-pgpmime]"
 823      "\t\t  Message to forward: \\[mh-compose-forward]\n"
 824      "                          "
 825      "\t\t  Signature:          \\[mh-insert-signature]"))
 826   "Key binding cheat sheet.
 827
 828 This is an associative array which is used to show the most common commands.
 829 The key is a prefix char. The value is one or more strings which are
 830 concatenated together and displayed in the minibuffer if ? is pressed after
 831 the prefix character. The special key nil is used to display the
 832 non-prefixed commands.
 833
 834 The substitutions described in `substitute-command-keys' are performed as
 835 well.")
 836
 837 ;;;###mh-autoload
 838 (defun mh-fill-paragraph-function (arg)
 839   "Fill paragraph at or after point.
 840 Prefix ARG means justify as well. This function enables `fill-paragraph' to
 841 work better in MH-Letter mode."
 842   (interactive "P")
 843   (let ((fill-paragraph-function) (fill-prefix))
 844     (if (mh-in-header-p)
 845         (mail-mode-fill-paragraph arg)
 846       (fill-paragraph arg))))
 847
 848 ;; Avoid compiler warnings in XEmacs and Emacs 20
 849 (eval-when-compile
 850   (defvar tool-bar-mode)
 851   (defvar tool-bar-map))
 852
 853 ;;;###autoload
 854 (define-derived-mode mh-letter-mode text-mode "MH-Letter"
 855   "Mode for composing letters in MH-E.\\<mh-letter-mode-map>
 856
 857 When you have finished composing, type \\[mh-send-letter] to send the message
 858 using the MH mail handling system.
 859
 860 There are two types of MIME directives used by MH-E: Gnus and MH. The option
 861 `mh-compose-insertion' controls what type of directives are inserted by MH-E
 862 commands. These directives can be converted to MIME body parts by running
 863 \\[mh-edit-mhn] for mhn directives or \\[mh-mml-to-mime] for Gnus directives.
 864 This step is mandatory if these directives are added manually. If the
 865 directives are inserted with MH-E commands such as \\[mh-compose-insertion],
 866 the directives are expanded automatically when the letter is sent.
 867
 868 Options that control this mode can be changed with
 869 \\[customize-group]; specify the \"mh-compose\" group.
 870
 871 When a message is composed, the hooks `text-mode-hook' and
 872 `mh-letter-mode-hook' are run.
 873
 874 \\{mh-letter-mode-map}"
 875   (or mh-user-path (mh-find-path))
 876   (make-local-variable 'mh-send-args)
 877   (make-local-variable 'mh-annotate-char)
 878   (make-local-variable 'mh-annotate-field)
 879   (make-local-variable 'mh-previous-window-config)
 880   (make-local-variable 'mh-sent-from-folder)
 881   (make-local-variable 'mh-sent-from-msg)
 882   (make-local-variable 'mail-header-separator)
 883   (setq mail-header-separator mh-mail-header-separator) ;override sendmail.el
 884   (make-local-variable 'mh-help-messages)
 885   (setq mh-help-messages mh-letter-mode-help-messages)
 886   (setq buffer-invisibility-spec '((vanish . t) t))
 887   (set (make-local-variable 'line-move-ignore-invisible) t)
 888
 889   ;; Set mh-mail-header-end-marker to remember end of message header.
 890   (set (make-local-variable 'mh-letter-mail-header-end-marker)
 891        (set-marker (make-marker) (save-excursion
 892                                    (goto-char (mh-mail-header-end))
 893                                    (line-beginning-position 2))))
 894
 895   ;; From sendmail.el for proper paragraph fill
 896   ;; sendmail.el also sets a normal-auto-fill-function (not done here)
 897   (make-local-variable 'paragraph-separate)
 898   (make-local-variable 'paragraph-start)
 899   (make-local-variable 'fill-paragraph-function)
 900   (setq fill-paragraph-function 'mh-fill-paragraph-function)
 901   (make-local-variable 'adaptive-fill-regexp)
 902   (setq adaptive-fill-regexp
 903         (concat adaptive-fill-regexp
 904                 "\\|[ \t]*[-[:alnum:]]*>+[ \t]*"))
 905   (make-local-variable 'adaptive-fill-first-line-regexp)
 906   (setq adaptive-fill-first-line-regexp
 907         (concat adaptive-fill-first-line-regexp
 908                 "\\|[ \t]*[-[:alnum:]]*>+[ \t]*"))
 909   ;; `-- ' precedes the signature.  `-----' appears at the start of the
 910   ;; lines that delimit forwarded messages.
 911   ;; Lines containing just >= 3 dashes, perhaps after whitespace,
 912   ;; are also sometimes used and should be separators.
 913   (setq paragraph-start (concat (regexp-quote mail-header-separator)
 914                                 "\\|\t*\\([-|#;>* ]\\|(?[0-9]+[.)]\\)+$"
 915                                 "\\|[ \t]*[[:alnum:]]*>+[ \t]*$\\|[ \t]*$\\|"
 916                                 "-- $\\|---+$\\|"
 917                                 page-delimiter))
 918   (setq paragraph-separate paragraph-start)
 919   ;; --- End of code from sendmail.el ---
 920
 921   ;; Enable undo since a show-mode buffer might have been reused.
 922   (buffer-enable-undo)
 923   (set (make-local-variable 'tool-bar-map) mh-letter-tool-bar-map)
 924   (mh-funcall-if-exists mh-toolbar-init :letter)
 925   (make-local-variable 'font-lock-defaults)
 926   (cond
 927    ((or (equal mh-highlight-citation-p 'font-lock)
 928         (equal mh-highlight-citation-p 'gnus))
 929     ;; Let's use font-lock even if gnus is used in show-mode.  The reason
 930     ;; is that gnus uses static text properties which are not appropriate
 931     ;; for a buffer that will be edited.  So the choice here is either fontify
 932     ;; the citations and header...
 933     (setq font-lock-defaults '(mh-letter-font-lock-keywords t)))
 934    (t
 935     ;; ...or the header only
 936     (setq font-lock-defaults '(mh-show-font-lock-keywords t))))
 937   (easy-menu-add mh-letter-menu)
 938   (setq fill-column mh-letter-fill-column)
 939   ;; If text-mode-hook turned on auto-fill, tune it for messages
 940   (when auto-fill-function
 941     (make-local-variable 'auto-fill-function)
 942     (setq auto-fill-function 'mh-auto-fill-for-letter)))
 943
 944 (defun mh-font-lock-field-data (limit)
 945   "Find header field region between point and LIMIT."
 946   (and (< (point) (mh-letter-header-end))
 947        (< (point) limit)
 948        (let ((end (min limit (mh-letter-header-end)))
 949              (point (point))
 950              data-end data-begin field)
 951          (end-of-line)
 952          (setq data-end (if (re-search-forward "^[^ \t]" end t)
 953                             (match-beginning 0)
 954                           end))
 955          (goto-char (1- data-end))
 956          (if (not (re-search-backward "\\(^[^ \t][^:]*\\):[ \t]*" nil t))
 957              (setq data-begin (point-min))
 958            (setq data-begin (match-end 0))
 959            (setq field (match-string 1)))
 960          (setq data-begin (max point data-begin))
 961          (if (and field (mh-letter-skipped-header-field-p field))
 962              (set-match-data nil)
 963            (set-match-data (list data-begin data-end data-begin data-end)))
 964          (goto-char (if (equal point data-end) (1+ data-end) data-end))
 965          t)))
 966
 967 (defun mh-letter-header-end ()
 968   "Find the end of header from `mh-letter-mail-header-end-marker'."
 969   (save-excursion
 970     (goto-char (marker-position mh-letter-mail-header-end-marker))
 971     (forward-line -1)
 972     (point)))
 973
 974 (defun mh-auto-fill-for-letter ()
 975   "Perform auto-fill for message.
 976 Header is treated specially by inserting a tab before continuation lines."
 977   (if (mh-in-header-p)
 978       (let ((fill-prefix "\t"))
 979         (do-auto-fill))
 980     (do-auto-fill)))
 981
 982 (defun mh-insert-header-separator ()
 983   "Insert `mh-mail-header-separator', if absent."
 984   (save-excursion
 985     (goto-char (point-min))
 986     (rfc822-goto-eoh)
 987     (if (looking-at "$")
 988         (insert mh-mail-header-separator))))
 989
 990 ;;;###mh-autoload
 991 (defun mh-to-field ()
 992   "Move point to the end of a specified header field.
 993 The field is indicated by the previous keystroke (the last keystroke
 994 of the command) according to the list in the variable `mh-to-field-choices'.
 995 Create the field if it does not exist.  Set the mark to point before moving."
 996   (interactive)
 997   (expand-abbrev)
 998   (let ((target (cdr (or (assoc (char-to-string (logior last-input-char ?`))
 999                                 mh-to-field-choices)
1000                          ;; also look for a char for version 4 compat
1001                          (assoc (logior last-input-char ?`)
1002                                 mh-to-field-choices))))
1003         (case-fold-search t))
1004     (push-mark)
1005     (cond ((mh-position-on-field target)
1006            (let ((eol (point)))
1007              (skip-chars-backward " \t")
1008              (delete-region (point) eol))
1009            (if (and (not (eq (logior last-input-char ?`) ?s))
1010                     (save-excursion
1011                       (backward-char 1)
1012                       (not (looking-at "[:,]"))))
1013                (insert ", ")
1014              (insert " ")))
1015           (t
1016            (if (mh-position-on-field "To:")
1017                (forward-line 1))
1018            (insert (format "%s \n" target))
1019            (backward-char 1)))))
1020
1021 ;;;###mh-autoload
1022 (defun mh-to-fcc (&optional folder)
1023   "Insert an Fcc: FOLDER field in the current message.
1024 Prompt for the field name with a completion list of the current folders."
1025   (interactive)
1026   (or folder
1027       (setq folder (mh-prompt-for-folder
1028                     "Fcc"
1029                     (or (and mh-default-folder-for-message-function
1030                              (save-excursion
1031                                (goto-char (point-min))
1032                                (funcall
1033                                 mh-default-folder-for-message-function)))
1034                         "")
1035                     t)))
1036   (let ((last-input-char ?\C-f))
1037     (expand-abbrev)
1038     (save-excursion
1039       (mh-to-field)
1040       (insert (if (mh-folder-name-p folder)
1041                   (substring folder 1)
1042                 folder)))))
1043
1044 ;;;###mh-autoload
1045 (defun mh-insert-signature ()
1046   "Insert the file named by `mh-signature-file-name' at point.
1047 The value of `mh-letter-insert-signature-hook' is a list of functions to be
1048 called, with no arguments, before the signature is actually inserted."
1049   (interactive)
1050   (let ((mh-signature-file-name mh-signature-file-name))
1051     (run-hooks 'mh-letter-insert-signature-hook)
1052     (if mh-signature-file-name
1053         (insert-file-contents mh-signature-file-name)))
1054   (force-mode-line-update))
1055
1056 ;;;###mh-autoload
1057 (defun mh-check-whom ()
1058   "Verify recipients of the current letter, showing expansion of any aliases."
1059   (interactive)
1060   (let ((file-name buffer-file-name))
1061     (save-buffer)
1062     (message "Checking recipients...")
1063     (mh-in-show-buffer (mh-recipients-buffer)
1064       (bury-buffer (current-buffer))
1065       (erase-buffer)
1066       (mh-exec-cmd-output "whom" t file-name))
1067     (message "Checking recipients...done")))
1068
1069 (defun mh-tidy-draft-buffer ()
1070   "Run when a draft buffer is destroyed."
1071   (let ((buffer (get-buffer mh-recipients-buffer)))
1072     (if buffer
1073         (kill-buffer buffer))))
1074
1075 \f
1076
1077 ;;; Routines to compose and send a letter.
1078
1079 (defun mh-insert-x-face ()
1080   "Append X-Face, Face or X-Image-URL field to header.
1081 If the field already exists, this function does nothing."
1082   (when (and (file-exists-p mh-x-face-file)
1083              (file-readable-p mh-x-face-file))
1084     (save-excursion
1085       (unless (or (mh-position-on-field "X-Face")
1086                   (mh-position-on-field "Face")
1087                   (mh-position-on-field "X-Image-URL"))
1088         (save-excursion
1089           (goto-char (+ (point) (cadr (insert-file-contents mh-x-face-file))))
1090           (if (not (looking-at "^"))
1091               (insert "\n")))
1092         (unless (looking-at "\\(X-Face\\|Face\\|X-Image-URL\\): ")
1093           (insert "X-Face: "))))))
1094
1095 (defvar mh-x-mailer-string nil
1096   "*String containing the contents of the X-Mailer header field.
1097 If nil, this variable is initialized to show the version of MH-E, Emacs, and
1098 MH the first time a message is composed.")
1099
1100 (defun mh-insert-x-mailer ()
1101   "Append an X-Mailer field to the header.
1102 The versions of MH-E, Emacs, and MH are shown."
1103
1104   ;; Lazily initialize mh-x-mailer-string.
1105   (when (and mh-insert-x-mailer-flag (null mh-x-mailer-string))
1106     (save-window-excursion
1107       ;; User would be confused if version info buffer disappeared magically,
1108       ;; so don't delete buffer if it already existed.
1109       (let ((info-buffer-exists-p (get-buffer mh-info-buffer)))
1110         (mh-version)
1111         (set-buffer mh-info-buffer)
1112         (if mh-nmh-flag
1113             (search-forward-regexp "^nmh-\\(\\S +\\)")
1114           (search-forward-regexp "^MH \\(\\S +\\)" nil t))
1115         (let ((x-mailer-mh (buffer-substring (match-beginning 1)
1116                                              (match-end 1))))
1117           (setq mh-x-mailer-string
1118                 (format "MH-E %s; %s %s; %sEmacs %s"
1119                         mh-version (if mh-nmh-flag "nmh" "MH") x-mailer-mh
1120                         (if mh-xemacs-flag "X" "GNU ")
1121                         (cond ((not mh-xemacs-flag) emacs-version)
1122                               ((string-match "[0-9.]*\\( +\([ a-z]+[0-9]+\)\\)?"
1123                                              emacs-version)
1124                                (match-string 0 emacs-version))
1125                               (t (format "%s.%s"
1126                                          emacs-major-version
1127                                          emacs-minor-version))))))
1128         (if (not info-buffer-exists-p)
1129             (kill-buffer mh-info-buffer)))))
1130   ;; Insert X-Mailer, but only if it doesn't already exist.
1131   (save-excursion
1132     (when (and mh-insert-x-mailer-flag
1133                (null (mh-goto-header-field "X-Mailer")))
1134       (mh-insert-fields "X-Mailer:" mh-x-mailer-string))))
1135
1136 (defun mh-regexp-in-field-p (regexp &rest fields)
1137   "Non-nil means REGEXP was found in FIELDS."
1138   (save-excursion
1139     (let ((search-result nil)
1140           (field))
1141       (while fields
1142         (setq field (car fields))
1143         (if (and (mh-goto-header-field field)
1144                  (re-search-forward
1145                   regexp (save-excursion (mh-header-field-end)(point)) t))
1146             (setq fields nil
1147                   search-result t)
1148           (setq fields (cdr fields))))
1149       search-result)))
1150
1151 ;;;###mh-autoload
1152 (defun mh-insert-auto-fields (&optional non-interactive)
1153   "Insert custom fields if To or Cc match `mh-auto-fields-list'.
1154 Sets buffer-local `mh-insert-auto-fields-done-local' when done and inserted
1155 something.  If NON-INTERACTIVE is non-nil, do not be verbose and only
1156 attempt matches if `mh-insert-auto-fields-done-local' is nil.
1157
1158 An `identity' entry is skipped if one was already entered manually."
1159   (interactive)
1160   (when (or (not non-interactive) (not mh-insert-auto-fields-done-local))
1161     (save-excursion
1162       (when (and (or (mh-goto-header-field "To:")(mh-goto-header-field "cc:")))
1163         (let ((list mh-auto-fields-list))
1164           (while list
1165             (let ((regexp (nth 0 (car list)))
1166                   (entries (nth 1 (car list))))
1167               (when (mh-regexp-in-field-p regexp "To:" "cc:")
1168                 (setq mh-insert-auto-fields-done-local t)
1169                 (if (not non-interactive)
1170                     (message "Matched for regexp %s" regexp))
1171                 (let ((entry-list entries))
1172                   (while entry-list
1173                     (let ((field (caar entry-list))
1174                           (value (cdar entry-list)))
1175                       (cond
1176                        ((equal "identity" field)
1177                         (when (and (not mh-identity-local)
1178                                    (assoc value mh-identity-list))
1179                           (mh-insert-identity value)))
1180                        (t
1181                         (mh-modify-header-field field value
1182                                                 (equal field "From")))))
1183                     (setq entry-list (cdr entry-list))))))
1184             (setq list (cdr list))))))))
1185
1186 (defun mh-modify-header-field (field value &optional overwrite-flag)
1187   "To header FIELD add VALUE.
1188 If OVERWRITE-FLAG is non-nil then the old value, if present, is discarded."
1189   (cond ((and overwrite-flag
1190               (mh-goto-header-field (concat field ":")))
1191          (insert " " value)
1192          (delete-region (point) (line-end-position)))
1193         ((and (not overwrite-flag)
1194               (mh-regexp-in-field-p (concat "\\b" value "\\b") field))
1195          ;; Already there, do nothing.
1196          )
1197         ((and (not overwrite-flag)
1198               (mh-goto-header-field (concat field ":")))
1199          (insert " " value ","))
1200         (t
1201          (mh-goto-header-end 0)
1202          (insert field ": " value "\n"))))
1203
1204 (defvar mh-letter-mail-header-end-marker nil)
1205
1206 (defun mh-compose-and-send-mail (draft send-args
1207                                        sent-from-folder sent-from-msg
1208                                        to subject cc
1209                                        annotate-char annotate-field
1210                                        config)
1211   "Edit and compose a draft message in buffer DRAFT and send or save it.
1212 SEND-ARGS is the argument passed to the send command.
1213 SENT-FROM-FOLDER is buffer containing scan listing of current folder, or
1214 nil if none exists.
1215 SENT-FROM-MSG is the message number or sequence name or nil.
1216 The TO, SUBJECT, and CC fields are passed to the
1217 `mh-compose-letter-function'.
1218 If ANNOTATE-CHAR is non-null, it is used to notate the scan listing of the
1219 message.  In that case, the ANNOTATE-FIELD is used to build a string
1220 for `mh-annotate-msg'.
1221 CONFIG is the window configuration to restore after sending the letter."
1222   (pop-to-buffer draft)
1223   (mh-letter-mode)
1224   (mh-insert-auto-fields t)
1225
1226   ;; mh-identity support
1227   (if (and (boundp 'mh-identity-default)
1228            mh-identity-default
1229            (not mh-identity-local))
1230       (mh-insert-identity mh-identity-default))
1231   (when (and (boundp 'mh-identity-list)
1232              mh-identity-list)
1233     (mh-identity-make-menu)
1234     (easy-menu-add mh-identity-menu))
1235
1236   ;; Extra fields
1237   (mh-insert-x-mailer)
1238   (mh-insert-x-face)
1239   ;; Hide skipped fields
1240   (mh-letter-hide-all-skipped-fields)
1241
1242   (setq mh-sent-from-folder sent-from-folder)
1243   (setq mh-sent-from-msg sent-from-msg)
1244   (setq mh-send-args send-args)
1245   (setq mh-annotate-char annotate-char)
1246   (setq mh-annotate-field annotate-field)
1247   (setq mh-previous-window-config config)
1248   (setq mode-line-buffer-identification (list "    {%b}"))
1249   (mh-logo-display)
1250   (mh-make-local-hook 'kill-buffer-hook)
1251   (add-hook 'kill-buffer-hook 'mh-tidy-draft-buffer nil t)
1252   (if (and (boundp 'mh-compose-letter-function)
1253            mh-compose-letter-function)
1254       ;; run-hooks will not pass arguments.
1255       (let ((value mh-compose-letter-function))
1256         (if (and (listp value) (not (eq (car value) 'lambda)))
1257             (while value
1258               (funcall (car value) to subject cc)
1259               (setq value (cdr value)))
1260           (funcall mh-compose-letter-function to subject cc)))))
1261
1262 (defun mh-letter-mode-message ()
1263   "Display a help message for users of `mh-letter-mode'.
1264 This should be the last function called when composing the draft."
1265   (message "%s" (substitute-command-keys
1266                  (concat "Type \\[mh-send-letter] to send message, "
1267                          "\\[mh-help] for help."))))
1268
1269 ;;;###mh-autoload
1270 (defun mh-send-letter (&optional arg)
1271   "Send the draft letter in the current buffer.
1272 If optional prefix argument ARG is provided, monitor delivery.
1273 The value of `mh-before-send-letter-hook' is a list of functions to be called,
1274 with no arguments, before doing anything.
1275 Run `\\[mh-edit-mhn]' if mhn directives are present; otherwise
1276 run `\\[mh-mml-to-mime]' if mml directives are present.
1277 Insert X-Mailer field if variable `mh-insert-x-mailer-flag' is set.
1278 Insert X-Face field if the file specified by `mh-x-face-file' exists."
1279   (interactive "P")
1280   (run-hooks 'mh-before-send-letter-hook)
1281   (mh-insert-auto-fields t)
1282   (cond ((mh-mhn-directive-present-p)
1283          (mh-edit-mhn))
1284         ((mh-mml-directive-present-p)
1285          (mh-mml-to-mime)))
1286   (save-buffer)
1287   (message "Sending...")
1288   (let ((draft-buffer (current-buffer))
1289         (file-name buffer-file-name)
1290         (config mh-previous-window-config)
1291         (coding-system-for-write
1292          (if (and (local-variable-p 'buffer-file-coding-system
1293                                     (current-buffer)) ;XEmacs needs two args
1294                   ;; We're not sure why, but buffer-file-coding-system
1295                   ;; tends to get set to undecided-unix.
1296                   (not (memq buffer-file-coding-system
1297                              '(undecided undecided-unix undecided-dos))))
1298              buffer-file-coding-system
1299            (or (and (boundp 'sendmail-coding-system) sendmail-coding-system)
1300                (and (boundp 'default-buffer-file-coding-system )
1301                     default-buffer-file-coding-system)
1302                'iso-latin-1))))
1303     ;; The default BCC encapsulation will make a MIME message unreadable.
1304     ;; With nmh use the -mime arg to prevent this.
1305     (if (and mh-nmh-flag
1306              (mh-goto-header-field "Bcc:")
1307              (mh-goto-header-field "Content-Type:"))
1308         (setq mh-send-args (format "-mime %s" mh-send-args)))
1309     (cond (arg
1310            (pop-to-buffer mh-mail-delivery-buffer)
1311            (erase-buffer)
1312            (mh-exec-cmd-output mh-send-prog t "-watch" "-nopush"
1313                                "-nodraftfolder" mh-send-args file-name)
1314            (goto-char (point-max))      ; show the interesting part
1315            (recenter -1)
1316            (set-buffer draft-buffer))   ; for annotation below
1317           (t
1318            (mh-exec-cmd-daemon mh-send-prog nil "-nodraftfolder" "-noverbose"
1319                                mh-send-args file-name)))
1320     (if mh-annotate-char
1321         (mh-annotate-msg mh-sent-from-msg
1322                          mh-sent-from-folder
1323                          mh-annotate-char
1324                          "-component" mh-annotate-field
1325                          "-text" (format "\"%s %s\""
1326                                          (mh-get-header-field "To:")
1327                                          (mh-get-header-field "Cc:"))))
1328
1329     (cond ((or (not arg)
1330                (y-or-n-p "Kill draft buffer? "))
1331            (kill-buffer draft-buffer)
1332            (if config
1333                (set-window-configuration config))))
1334     (if arg
1335         (message "Sending...done")
1336       (message "Sending...backgrounded"))))
1337
1338 ;;;###mh-autoload
1339 (defun mh-insert-letter (folder message verbatim)
1340   "Insert a message into the current letter.
1341 Removes the header fields according to the variable `mh-invisible-headers'.
1342 Prefixes each non-blank line with `mh-ins-buf-prefix', unless
1343 `mh-yank-from-start-of-msg' is set for supercite in which case supercite is
1344 used to format the message.
1345 Prompts for FOLDER and MESSAGE.  If prefix argument VERBATIM provided, do
1346 not indent and do not delete headers.  Leaves the mark before the letter
1347 and point after it."
1348   (interactive
1349    (list (mh-prompt-for-folder "Message from" mh-sent-from-folder nil)
1350          (read-input (format "Message number%s: "
1351                              (if (numberp mh-sent-from-msg)
1352                                  (format " [%d]" mh-sent-from-msg)
1353                                "")))
1354          current-prefix-arg))
1355   (save-restriction
1356     (narrow-to-region (point) (point))
1357     (let ((start (point-min)))
1358       (if (equal message "") (setq message (int-to-string mh-sent-from-msg)))
1359       (insert-file-contents
1360        (expand-file-name message (mh-expand-file-name folder)))
1361       (when (not verbatim)
1362         (mh-clean-msg-header start mh-invisible-headers mh-visible-headers)
1363         (goto-char (point-max))         ;Needed for sc-cite-original
1364         (push-mark)                     ;Needed for sc-cite-original
1365         (goto-char (point-min))         ;Needed for sc-cite-original
1366         (mh-insert-prefix-string mh-ins-buf-prefix)))))
1367
1368 (defun mh-extract-from-attribution ()
1369   "Extract phrase or comment from From header field."
1370   (save-excursion
1371     (if (not (mh-goto-header-field "From: "))
1372         nil
1373       (skip-chars-forward " ")
1374       (cond
1375        ((looking-at "\"\\([^\"\n]+\\)\" \\(<.+>\\)")
1376         (format "%s %s %s" (match-string 1)(match-string 2)
1377                 mh-extract-from-attribution-verb))
1378        ((looking-at "\\([^<\n]+<.+>\\)$")
1379         (format "%s %s" (match-string 1) mh-extract-from-attribution-verb))
1380        ((looking-at "\\([^ ]+@[^ ]+\\) +(\\(.+\\))$")
1381         (format "%s <%s> %s" (match-string 2)(match-string 1)
1382                 mh-extract-from-attribution-verb))
1383        ((looking-at " *\\(.+\\)$")
1384         (format "%s %s" (match-string 1) mh-extract-from-attribution-verb))))))
1385
1386 ;;;###mh-autoload
1387 (defun mh-yank-cur-msg ()
1388   "Insert the current message into the draft buffer.
1389 Prefix each non-blank line in the message with the string in
1390 `mh-ins-buf-prefix'.  If a region is set in the message's buffer, then
1391 only the region will be inserted.  Otherwise, the entire message will
1392 be inserted if `mh-yank-from-start-of-msg' is non-nil.  If this variable
1393 is nil, the portion of the message following the point will be yanked.
1394 If `mh-delete-yanked-msg-window-flag' is non-nil, any window displaying the
1395 yanked message will be deleted."
1396   (interactive)
1397   (if (and mh-sent-from-folder
1398            (save-excursion (set-buffer mh-sent-from-folder) mh-show-buffer)
1399            (save-excursion (set-buffer mh-sent-from-folder)
1400                            (get-buffer mh-show-buffer))
1401            mh-sent-from-msg)
1402       (let ((to-point (point))
1403             (to-buffer (current-buffer)))
1404         (set-buffer mh-sent-from-folder)
1405         (if mh-delete-yanked-msg-window-flag
1406             (delete-windows-on mh-show-buffer))
1407         (set-buffer mh-show-buffer)     ; Find displayed message
1408         (let* ((from-attr (mh-extract-from-attribution))
1409                (yank-region (mh-mark-active-p nil))
1410                (mh-ins-str
1411                 (cond ((and yank-region
1412                             (or (eq 'supercite mh-yank-from-start-of-msg)
1413                                 (eq 'autosupercite mh-yank-from-start-of-msg)
1414                                 (eq t mh-yank-from-start-of-msg)))
1415                        ;; supercite needs the full header
1416                        (concat
1417                         (buffer-substring (point-min) (mh-mail-header-end))
1418                         "\n"
1419                         (buffer-substring (region-beginning) (region-end))))
1420                       (yank-region
1421                        (buffer-substring (region-beginning) (region-end)))
1422                       ((or (eq 'body mh-yank-from-start-of-msg)
1423                            (eq 'attribution
1424                                mh-yank-from-start-of-msg)
1425                            (eq 'autoattrib
1426                                mh-yank-from-start-of-msg))
1427                        (buffer-substring
1428                         (save-excursion
1429                           (goto-char (point-min))
1430                           (mh-goto-header-end 1)
1431                           (point))
1432                         (point-max)))
1433                       ((or (eq 'supercite mh-yank-from-start-of-msg)
1434                            (eq 'autosupercite mh-yank-from-start-of-msg)
1435                            (eq t mh-yank-from-start-of-msg))
1436                        (buffer-substring (point-min) (point-max)))
1437                       (t
1438                        (buffer-substring (point) (point-max))))))
1439           (set-buffer to-buffer)
1440           (save-restriction
1441             (narrow-to-region to-point to-point)
1442             (insert (mh-filter-out-non-text mh-ins-str))
1443             (goto-char (point-max))     ;Needed for sc-cite-original
1444             (push-mark)                 ;Needed for sc-cite-original
1445             (goto-char (point-min))     ;Needed for sc-cite-original
1446             (mh-insert-prefix-string mh-ins-buf-prefix)
1447             (if (or (eq 'attribution mh-yank-from-start-of-msg)
1448                     (eq 'autoattrib mh-yank-from-start-of-msg))
1449                 (insert from-attr "\n\n"))
1450             ;; If the user has selected a region, he has already "edited" the
1451             ;; text, so leave the cursor at the end of the yanked text. In
1452             ;; either case, leave a mark at the opposite end of the included
1453             ;; text to make it easy to jump or delete to the other end of the
1454             ;; text.
1455             (push-mark)
1456             (goto-char (point-max))
1457             (if (null yank-region)
1458                 (mh-exchange-point-and-mark-preserving-active-mark)))))
1459     (error "There is no current message")))
1460
1461 (defun mh-filter-out-non-text (string)
1462   "Return STRING but without adornments such as MIME buttons and smileys."
1463   (with-temp-buffer
1464     ;; Insert the string to filter
1465     (insert string)
1466     (goto-char (point-min))
1467
1468     ;; Remove the MIME buttons
1469     (let ((can-move-forward t)
1470           (in-button nil))
1471       (while can-move-forward
1472         (cond ((and (not (get-text-property (point) 'mh-data))
1473                     in-button)
1474                (delete-region (1- (point)) (point))
1475                (setq in-button nil))
1476               ((get-text-property (point) 'mh-data)
1477                (delete-region (point)
1478                               (save-excursion (forward-line) (point)))
1479                (setq in-button t))
1480               (t (setq can-move-forward (= (forward-line) 0))))))
1481
1482     ;; Return the contents without properties... This gets rid of emphasis
1483     ;; and smileys
1484     (buffer-substring-no-properties (point-min) (point-max))))
1485
1486 (defun mh-insert-prefix-string (mh-ins-string)
1487   "Insert prefix string before each line in buffer.
1488 The inserted letter is cited using `sc-cite-original' if
1489 `mh-yank-from-start-of-msg' is one of 'supercite or 'autosupercite. Otherwise,
1490 simply insert MH-INS-STRING before each line."
1491   (goto-char (point-min))
1492   (cond ((or (eq mh-yank-from-start-of-msg 'supercite)
1493              (eq mh-yank-from-start-of-msg 'autosupercite))
1494          (sc-cite-original))
1495         (mail-citation-hook
1496          (run-hooks 'mail-citation-hook))
1497         (mh-yank-hooks                  ;old hook name
1498          (run-hooks 'mh-yank-hooks))
1499         (t
1500          (or (bolp) (forward-line 1))
1501          (while (< (point) (point-max))
1502            (insert mh-ins-string)
1503            (forward-line 1))
1504          (goto-char (point-min)))))     ;leave point like sc-cite-original
1505
1506 ;;;###mh-autoload
1507 (defun mh-fully-kill-draft ()
1508   "Kill the draft message file and the draft message buffer.
1509 Use \\[kill-buffer] if you don't want to delete the draft message file."
1510   (interactive)
1511   (if (y-or-n-p "Kill draft message? ")
1512       (let ((config mh-previous-window-config))
1513         (if (file-exists-p buffer-file-name)
1514             (delete-file buffer-file-name))
1515         (set-buffer-modified-p nil)
1516         (kill-buffer (buffer-name))
1517         (message "")
1518         (if config
1519             (set-window-configuration config)))
1520     (error "Message not killed")))
1521
1522 (defun mh-current-fill-prefix ()
1523   "Return the `fill-prefix' on the current line as a string."
1524   (save-excursion
1525     (beginning-of-line)
1526     ;; This assumes that the major-mode sets up adaptive-fill-regexp
1527     ;; correctly such as mh-letter-mode or sendmail.el's mail-mode.  But
1528     ;; perhaps I should use the variable and simply inserts its value here,
1529     ;; and set it locally in a let scope.  --psg
1530     (if (re-search-forward adaptive-fill-regexp nil t)
1531         (match-string 0)
1532       "")))
1533
1534 ;;;###mh-autoload
1535 (defun mh-open-line ()
1536   "Insert a newline and leave point after it.
1537 In addition, insert newline and quoting characters before text after point.
1538 This is useful in breaking up paragraphs in replies."
1539   (interactive)
1540   (let ((column (current-column))
1541         (prefix (mh-current-fill-prefix)))
1542     (if (> (length prefix) column)
1543         (message "Sorry, point seems to be within the line prefix")
1544       (newline 2)
1545       (insert prefix)
1546       (while (> column (current-column))
1547         (insert " "))
1548       (forward-line -1))))
1549
1550 (mh-do-in-xemacs (defvar mail-abbrevs))
1551
1552 ;;;###mh-autoload
1553 (defun mh-complete-word (word choices begin end)
1554   "Complete WORD at from CHOICES.
1555 Any match found replaces the text from BEGIN to END."
1556   (let ((completion (try-completion word choices)))
1557     (cond ((eq completion t)
1558            (message "Completed: %s" word))
1559           ((null completion)
1560            (message "No completion for `%s'" word))
1561           ((stringp completion)
1562            (if (equal word completion)
1563                (with-output-to-temp-buffer "*Completions*"
1564                  (display-completion-list (all-completions word choices)))
1565              (delete-region begin end)
1566              (insert completion))))))
1567
1568 ;;;###mh-autoload
1569 (defun mh-beginning-of-word (&optional n)
1570   "Return position of the N th word backwards."
1571   (unless n (setq n 1))
1572   (let ((syntax-table (syntax-table)))
1573     (unwind-protect
1574         (save-excursion
1575           (mh-funcall-if-exists mail-abbrev-make-syntax-table)
1576           (set-syntax-table mail-abbrev-syntax-table)
1577           (backward-word n)
1578           (point))
1579       (set-syntax-table syntax-table))))
1580
1581 (defun mh-folder-expand-at-point ()
1582   "Do folder name completion in Fcc header field."
1583   (let* ((end (point))
1584          (beg (mh-beginning-of-word))
1585          (folder (buffer-substring beg end))
1586          (leading-plus (and (> (length folder) 0) (equal (aref folder 0) ?+)))
1587          (last-slash (mh-search-from-end ?/ folder))
1588          (prefix (and last-slash (substring folder 0 last-slash)))
1589          (choices (mapcar #'(lambda (x)
1590                               (list (cond (prefix (format "%s/%s" prefix x))
1591                                           (leading-plus (format "+%s" x))
1592                                           (t x))))
1593                           (mh-folder-completion-function folder nil t))))
1594     (mh-complete-word folder choices beg end)))
1595
1596 ;; XXX: This should probably be customizable
1597 (defvar mh-letter-complete-function-alist
1598   '((cc . mh-alias-letter-expand-alias)
1599     (bcc . mh-alias-letter-expand-alias)
1600     (dcc . mh-alias-letter-expand-alias)
1601     (fcc . mh-folder-expand-at-point)
1602     (from . mh-alias-letter-expand-alias)
1603     (mail-followup-to . mh-alias-letter-expand-alias)
1604     (reply-to . mh-alias-letter-expand-alias)
1605     (to . mh-alias-letter-expand-alias))
1606   "Alist of header fields and completion functions to use.")
1607
1608 (defun mh-letter-complete (arg)
1609   "Perform completion on header field or word preceding point.
1610 Alias completion is done within the mail header on selected fields based on
1611 the matches in `mh-letter-complete-function-alist'. Elsewhere the function
1612 designated by `mh-letter-complete-function' is used and given the prefix ARG,
1613 if present."
1614   (interactive "P")
1615   (let ((func nil))
1616     (cond ((not (mh-in-header-p))
1617            (funcall mh-letter-complete-function arg))
1618           ((setq func (cdr (assoc (mh-letter-header-field-at-point)
1619                                   mh-letter-complete-function-alist)))
1620            (funcall func))
1621           (t (funcall mh-letter-complete-function arg)))))
1622
1623 (defun mh-letter-complete-or-space (arg)
1624   "Perform completion or insert space.
1625 If `mh-compose-space-does-completion-flag' is nil (the default) a space is
1626 inserted.
1627
1628 Otherwise, if point is in the message header and the preceding character is
1629 not whitespace then do completion. Otherwise insert a space character.
1630
1631 ARG is the number of spaces inserted."
1632   (interactive "p")
1633   (let ((func nil)
1634         (end-of-prev (save-excursion
1635                        (goto-char (mh-beginning-of-word))
1636                        (mh-beginning-of-word -1))))
1637     (cond ((not mh-compose-space-does-completion-flag)
1638            (self-insert-command arg))
1639           ((not (mh-in-header-p)) (self-insert-command arg))
1640           ((> (point) end-of-prev) (self-insert-command arg))
1641           ((setq func (cdr (assoc (mh-letter-header-field-at-point)
1642                                   mh-letter-complete-function-alist)))
1643            (funcall func))
1644           (t (self-insert-command arg)))))
1645
1646 (defun mh-letter-confirm-address ()
1647   "Flash alias expansion if `mh-alias-flash-on-comma' is non-nil."
1648   (interactive)
1649   (cond ((not (mh-in-header-p)) (self-insert-command 1))
1650         ((eq (cdr (assoc (mh-letter-header-field-at-point)
1651                          mh-letter-complete-function-alist))
1652              'mh-alias-letter-expand-alias)
1653          (mh-alias-reload-maybe)
1654          (mh-alias-minibuffer-confirm-address))
1655         (t (self-insert-command 1))))
1656
1657 (defvar mh-letter-header-field-regexp "^\\([A-Za-z][A-Za-z0-9-]*\\):")
1658
1659 (defun mh-letter-header-field-at-point ()
1660   "Return the header field name at point.
1661 A symbol is returned whose name is the string obtained by downcasing the field
1662 name."
1663   (save-excursion
1664     (end-of-line)
1665     (and (re-search-backward mh-letter-header-field-regexp nil t)
1666          (intern (downcase (match-string 1))))))
1667
1668 ;;;###mh-autoload
1669 (defun mh-letter-next-header-field-or-indent (arg)
1670   "Move to next field or indent depending on point.
1671 In the message header, go to the next field. Elsewhere call
1672 `indent-relative' as usual with optional prefix ARG."
1673   (interactive "P")
1674   (let ((header-end (save-excursion
1675                       (goto-char (mh-mail-header-end))
1676                       (forward-line)
1677                       (point))))
1678     (if (> (point) header-end)
1679         (indent-relative arg)
1680       (mh-letter-next-header-field))))
1681
1682 (defun mh-letter-next-header-field ()
1683   "Cycle to the next header field.
1684 If we are at the last header field go to the start of the message body."
1685   (let ((header-end (mh-mail-header-end)))
1686     (cond ((>= (point) header-end) (goto-char (point-min)))
1687           ((< (point) (progn
1688                         (beginning-of-line)
1689                         (re-search-forward mh-letter-header-field-regexp
1690                                            (line-end-position) t)
1691                         (point)))
1692            (beginning-of-line))
1693           (t (end-of-line)))
1694     (cond ((re-search-forward mh-letter-header-field-regexp header-end t)
1695            (if (mh-letter-skipped-header-field-p (match-string 1))
1696                (mh-letter-next-header-field)
1697              (mh-letter-skip-leading-whitespace-in-header-field)))
1698           (t (goto-char header-end)
1699              (forward-line)))))
1700
1701 ;;;###mh-autoload
1702 (defun mh-letter-previous-header-field ()
1703   "Cycle to the previous header field.
1704 If we are at the first header field go to the start of the message body."
1705   (interactive)
1706   (let ((header-end (mh-mail-header-end)))
1707     (if (>= (point) header-end)
1708         (goto-char header-end)
1709       (mh-header-field-beginning))
1710     (cond ((re-search-backward mh-letter-header-field-regexp nil t)
1711            (if (mh-letter-skipped-header-field-p (match-string 1))
1712                (mh-letter-previous-header-field)
1713            (goto-char (match-end 0))
1714            (mh-letter-skip-leading-whitespace-in-header-field)))
1715           (t (goto-char header-end)
1716              (forward-line)))))
1717
1718 (defun mh-letter-skipped-header-field-p (field)
1719   "Check if FIELD is to be skipped."
1720   (let ((field (downcase field)))
1721     (loop for x in mh-compose-skipped-header-fields
1722           when (equal (downcase x) field) return t
1723           finally return nil)))
1724
1725 (defun mh-letter-skip-leading-whitespace-in-header-field ()
1726   "Skip leading whitespace in a header field.
1727 If the header field doesn't have at least one space after the colon then a
1728 space character is added."
1729   (let ((need-space t))
1730     (while (memq (char-after) '(?\t ?\ ))
1731       (forward-char)
1732       (setq need-space nil))
1733     (when need-space (insert " "))))
1734
1735 (defvar mh-hidden-header-keymap
1736   (let ((map (make-sparse-keymap)))
1737     (mh-do-in-gnu-emacs
1738       (define-key map [mouse-2] 'mh-letter-toggle-header-field-display-button))
1739     (mh-do-in-xemacs
1740       (define-key map '(button2)
1741         'mh-letter-toggle-header-field-display-button))
1742     map))
1743
1744 (defun mh-letter-toggle-header-field-display-button (event)
1745   "Toggle header field display at location of EVENT.
1746 This function does the same thing as `mh-letter-toggle-header-field-display'
1747 except that it is callable from a mouse button."
1748   (interactive "e")
1749   (mh-do-at-event-location event
1750     (mh-letter-toggle-header-field-display nil)))
1751
1752 (defun mh-letter-toggle-header-field-display (arg)
1753   "Toggle display of header field at point.
1754 If the header is long or spread over multiple lines then hiding it will show
1755 the first few characters and replace the rest with an ellipsis.
1756
1757 If ARG is negative then header is hidden, if positive it is displayed. If ARG
1758 is the symbol `long' then keep at most the first 4 lines."
1759   (interactive (list nil))
1760   (when (and (mh-in-header-p)
1761              (progn
1762                (end-of-line)
1763                (re-search-backward mh-letter-header-field-regexp nil t)))
1764     (let ((buffer-read-only nil)
1765           (modified-flag (buffer-modified-p))
1766           (begin (point))
1767           end)
1768       (end-of-line)
1769       (setq end (1- (if (re-search-forward "^[^ \t]" nil t)
1770                         (match-beginning 0)
1771                       (point-max))))
1772       (goto-char begin)
1773       ;; Make it clickable...
1774       (add-text-properties begin end `(keymap ,mh-hidden-header-keymap
1775                                        mouse-face highlight))
1776       (unwind-protect
1777           (cond ((or (and (not arg)
1778                           (text-property-any begin end 'invisible 'vanish))
1779                      (and (numberp arg) (>= arg 0))
1780                      (and (eq arg 'long) (> (line-beginning-position 5) end)))
1781                  (remove-text-properties begin end '(invisible nil))
1782                  (search-forward ":" (line-end-position) t)
1783                  (mh-letter-skip-leading-whitespace-in-header-field))
1784                 ((eq arg 'long)
1785                  (end-of-line 4)
1786                  (mh-letter-truncate-header-field end)
1787                  (beginning-of-line))
1788                 (t (end-of-line)
1789                    (mh-letter-truncate-header-field end)
1790                    (beginning-of-line)))
1791         (set-buffer-modified-p modified-flag)))))
1792
1793 (defun mh-letter-truncate-header-field (end)
1794   "Replace text from current line till END with an ellipsis.
1795 If the current line is too long truncate a part of it as well."
1796   (let ((max-len (min (window-width) 62)))
1797     (when (> (+ (current-column) 4) max-len)
1798       (backward-char (- (+ (current-column) 5) max-len)))
1799     (when (> end (point))
1800       (add-text-properties (point) end '(invisible vanish)))))
1801
1802 (defun mh-letter-hide-all-skipped-fields ()
1803   "Hide all skipped fields."
1804   (save-excursion
1805     (goto-char (point-min))
1806     (save-restriction
1807       (narrow-to-region (point) (mh-mail-header-end))
1808       (while (re-search-forward mh-letter-header-field-regexp nil t)
1809         (if (mh-letter-skipped-header-field-p (match-string 1))
1810             (mh-letter-toggle-header-field-display -1)
1811           (mh-letter-toggle-header-field-display 'long))
1812         (beginning-of-line 2)))))
1813
1814 (defun mh-interactive-read-address (prompt)
1815   "Read an address.
1816 If `mh-compose-prompt-flag' is non-nil, then read an address with PROMPT.
1817 Otherwise return the empty string."
1818   (if mh-compose-prompt-flag (mh-read-address prompt) ""))
1819
1820 (defun mh-interactive-read-string (prompt)
1821   "Read a string.
1822 If `mh-compose-prompt-flag' is non-nil, then read a string with PROMPT.
1823 Otherwise return the empty string."
1824   (if mh-compose-prompt-flag (read-string prompt) ""))
1825
1826 (defun mh-letter-adjust-point ()
1827   "Move cursor to first header field if are using the no prompt mode."
1828   (unless mh-compose-prompt-flag
1829     (goto-char (point-max))
1830     (mh-letter-next-header-field)))
1831
1832 ;;; Build the letter-mode keymap:
1833 ;;; If this changes, modify mh-letter-mode-help-messages accordingly, above.
1834 (gnus-define-keys  mh-letter-mode-map
1835   "\C-c?"               mh-help
1836   "\C-c\C-c"            mh-send-letter
1837   "\C-c\C-d"            mh-insert-identity
1838   "\C-c\M-d"            mh-insert-auto-fields
1839   "\C-c\C-e"            mh-edit-mhn
1840   "\C-c\C-f\C-b"        mh-to-field
1841   "\C-c\C-f\C-c"        mh-to-field
1842   "\C-c\C-f\C-d"        mh-to-field
1843   "\C-c\C-f\C-f"        mh-to-fcc
1844   "\C-c\C-f\C-r"        mh-to-field
1845   "\C-c\C-f\C-s"        mh-to-field
1846   "\C-c\C-f\C-t"        mh-to-field
1847   "\C-c\C-fb"           mh-to-field
1848   "\C-c\C-fc"           mh-to-field
1849   "\C-c\C-fd"           mh-to-field
1850   "\C-c\C-ff"           mh-to-fcc
1851   "\C-c\C-fr"           mh-to-field
1852   "\C-c\C-fs"           mh-to-field
1853   "\C-c\C-ft"           mh-to-field
1854   "\C-c\C-i"            mh-insert-letter
1855   "\C-c\C-m\C-e"        mh-mml-secure-message-encrypt-pgpmime
1856   "\C-c\C-m\C-f"        mh-compose-forward
1857   "\C-c\C-m\C-i"        mh-compose-insertion
1858   "\C-c\C-m\C-m"        mh-mml-to-mime
1859   "\C-c\C-m\C-s"        mh-mml-secure-message-sign-pgpmime
1860   "\C-c\C-m\C-u"        mh-revert-mhn-edit
1861   "\C-c\C-me"           mh-mml-secure-message-encrypt-pgpmime
1862   "\C-c\C-mf"           mh-compose-forward
1863   "\C-c\C-mi"           mh-compose-insertion
1864   "\C-c\C-mm"           mh-mml-to-mime
1865   "\C-c\C-ms"           mh-mml-secure-message-sign-pgpmime
1866   "\C-c\C-mu"           mh-revert-mhn-edit
1867   "\C-c\C-o"            mh-open-line
1868   "\C-c\C-q"            mh-fully-kill-draft
1869   "\C-c\C-\\"           mh-fully-kill-draft ;if no C-q
1870   "\C-c\C-s"            mh-insert-signature
1871   "\C-c\C-^"            mh-insert-signature ;if no C-s
1872   "\C-c\C-w"            mh-check-whom
1873   "\C-c\C-y"            mh-yank-cur-msg
1874   "\C-c\C-t"            mh-letter-toggle-header-field-display
1875   " "                   mh-letter-complete-or-space
1876   "\M-\t"               mh-letter-complete
1877   "\t"                  mh-letter-next-header-field-or-indent
1878   [backtab]             mh-letter-previous-header-field
1879   ","                   mh-letter-confirm-address)
1880
1881 ;; "C-c /" prefix is used in mh-letter-mode by pgp.el and mailcrypt.el.
1882
1883 ;;;###autoload(add-to-list 'auto-mode-alist '("/drafts/[0-9]+\\'" . mh-letter-mode))
1884
1885 (provide 'mh-comp)
1886
1887 ;;; Local Variables:
1888 ;;; indent-tabs-mode: nil
1889 ;;; sentence-end-double-space: nil
1890 ;;; End:
1891
1892 ;;; arch-tag: 62865511-e610-4923-b0b5-f45a8ab70a34
1893 ;;; mh-comp.el ends here