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