lisp/mail/mh-comp.el

   1 ;;; mh-comp --- mh-e functions for composing messages
   2 ;; Time-stamp: <95/08/19 17:48:59 gildea>
   3
   4 ;; Copyright (C) 1993, 1995 Free Software Foundation, Inc.
   5
   6 ;; This file is part of mh-e, part of GNU Emacs.
   7
   8 ;; GNU Emacs is free software; you can redistribute it and/or modify
   9 ;; it under the terms of the GNU General Public License as published by
  10 ;; the Free Software Foundation; either version 2, or (at your option)
  11 ;; any later version.
  12
  13 ;; GNU Emacs is distributed in the hope that it will be useful,
  14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;; GNU General Public License for more details.
  17
  18 ;; You should have received a copy of the GNU General Public License
  19 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  20 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  21 ;; Boston, MA 02111-1307, USA.
  22
  23 ;;; Commentary:
  24
  25 ;; Internal support for mh-e package.
  26
  27 ;;; Change Log:
  28
  29 ;; $Id: mh-comp.el,v 1.7 1995/11/03 02:28:52 kwzh Exp erik $
  30
  31 ;;; Code:
  32
  33 (provide 'mh-comp)
  34 (require 'mh-utils)
  35
  36 ;;; Site customization (see also mh-utils.el):
  37
  38 (defvar mh-send-prog "send"
  39   "Name of the MH send program.
  40 Some sites need to change this because of a name conflict.")
  41
  42 (defvar mh-redist-full-contents nil
  43   "Non-nil if the `dist' command needs whole letter for redistribution.
  44 This is the case only when `send' is compiled with the BERK option.
  45 If MH will not allow you to redist a previously redist'd msg, set to nil.")
  46
  47
  48 (defvar mh-note-repl "-"
  49   "String whose first character is used to notate replied to messages.")
  50
  51 (defvar mh-note-forw "F"
  52   "String whose first character is used to notate forwarded messages.")
  53
  54 (defvar mh-note-dist "R"
  55   "String whose first character is used to notate redistributed messages.")
  56
  57 (defvar mh-yank-hooks nil
  58   "Obsolete hook for modifying a citation just inserted in the mail buffer.
  59 Each hook function can find the citation between point and mark.
  60 And each hook function should leave point and mark around the citation
  61 text as modified.
  62
  63 This is a normal hook, misnamed for historical reasons.
  64 It is semi-obsolete and is only used if mail-citation-hook is nil.")
  65
  66 (defvar mail-citation-hook nil
  67   "*Hook for modifying a citation just inserted in the mail buffer.
  68 Each hook function can find the citation between point and mark.
  69 And each hook function should leave point and mark around the citation
  70 text as modified.
  71
  72 If this hook is entirely empty (nil), the text of the message is inserted
  73 with mh-ins-buf-prefix prefixed to each line.
  74
  75 See also the variable mh-yank-from-start-of-msg, which controls how
  76 much of the message passed to the hook.")
  77
  78 ;;; Copied from sendmail.el for Hyperbole
  79 (defvar mail-header-separator "--------"
  80   "*Line used by MH to separate headers from text in messages being composed.")
  81
  82 ;;; Personal preferences:
  83
  84 (defvar mh-delete-yanked-msg-window nil
  85   "*Controls window display when a message is yanked by \\<mh-letter-mode-map>\\[mh-yank-cur-msg].
  86 If non-nil, yanking the current message into a draft letter deletes any
  87 windows displaying the message.")
  88
  89 (defvar mh-yank-from-start-of-msg t
  90   "*Controls which part of a message is yanked by \\<mh-letter-mode-map>\\[mh-yank-cur-msg].
  91 If non-nil, include the entire message.  If the symbol `body', then yank the
  92 message minus the header.  If nil, yank only the portion of the message
  93 following the point.  If the show buffer has a region, this variable is
  94 ignored.")
  95
  96 (defvar mh-ins-buf-prefix "> "
  97   "*String to put before each non-blank line of a yanked or inserted message.
  98 \\<mh-letter-mode-map>Used when the message is inserted into an outgoing letter
  99 by \\[mh-insert-letter] or \\[mh-yank-cur-msg].")
 100
 101 (defvar mh-reply-default-reply-to nil
 102   "*Sets the person or persons to whom a reply will be sent.
 103 If nil, prompt for recipient.  If non-nil, then \\<mh-folder-mode-map>`\\[mh-reply]' will use this
 104 value and it should be one of \"from\", \"to\", \"cc\", or \"all\".
 105 The values \"cc\" and \"all\" do the same thing.")
 106
 107 (defvar mh-signature-file-name "~/.signature"
 108   "*Name of file containing the user's signature.
 109 Inserted into message by \\<mh-letter-mode-map>\\[mh-insert-signature].")
 110
 111 (defvar mh-forward-subject-format "%s: %s"
 112   "*Format to generate the Subject: line contents for a forwarded message.
 113 The two string arguments to the format are the sender of the original
 114 message and the original subject line.")
 115
 116 (defvar mh-comp-formfile "components"
 117   "Name of file to be used as a skeleton for composing messages.
 118 Default is \"components\".  If not a complete path name, the file
 119 is searched for first in the user's MH directory, then in the
 120 system MH lib directory.")
 121
 122 (defvar mh-repl-formfile "replcomps"
 123   "Name of file to be used as a skeleton for replying to messages.
 124 Default is \"replcomps\".  If not a complete path name, the file
 125 is searched for first in the user's MH directory, then in the
 126 system MH lib directory.")
 127
 128 ;;; Hooks:
 129
 130 (defvar mh-letter-mode-hook nil
 131   "Invoked in `mh-letter-mode' on a new letter.")
 132
 133 (defvar mh-compose-letter-function nil
 134   "Invoked when setting up a letter draft.
 135 It is passed three arguments: TO recipients, SUBJECT, and CC recipients.")
 136
 137 (defvar mh-before-send-letter-hook nil
 138   "Invoked at the beginning of the \\<mh-letter-mode-map>\\[mh-send-letter] command.")
 139
 140
 141 (defvar mh-rejected-letter-start
 142   (concat "^   ----- Unsent message follows -----$"     ;from sendmail V5
 143           "\\|^   ----- Original message follows -----$" ;from sendmail V8
 144           "\\|^------- Unsent Draft$"                   ;from MH itself
 145           "\\|^----------  Original Message  ----------$" ;from zmailer
 146           "\\|^  --- The unsent message follows ---$"   ;from AIX mail system
 147           "\\|^    Your message follows:$"              ;from MMDF-II
 148           "\\|^Content-Description: Returned Content$"  ;1993 KJ sendmail
 149           )
 150   "Regexp specifying the beginning of the wrapper around a returned letter.
 151 This wrapper is generated by the mail system when rejecting a letter.")
 152
 153 (defvar mh-new-draft-cleaned-headers
 154   "^Date:\\|^Received:\\|^Message-Id:\\|^From:\\|^Sender:\\|^Errors-To:\\|^Delivery-Date:\\|^Return-Path:"
 155   "Regexp of header lines to remove before offering a message as a new draft.
 156 Used by the \\<mh-folder-mode-map>`\\[mh-edit-again]' and `\\[mh-extract-rejected-mail]' commands.")
 157
 158 (defvar mh-to-field-choices '(("t" . "To:") ("s" . "Subject:") ("c" . "Cc:")
 159                               ("b" . "Bcc:") ("f" . "Fcc:") ("r" . "From:")
 160                               ("d" . "Dcc:"))
 161   "Alist of (final-character . field-name) choices for mh-to-field.")
 162
 163 (defvar mh-letter-mode-map (copy-keymap text-mode-map)
 164   "Keymap for composing mail.")
 165
 166 (defvar mh-letter-mode-syntax-table nil
 167   "Syntax table used by mh-e while in MH-Letter mode.")
 168
 169 (if mh-letter-mode-syntax-table
 170     ()
 171     (setq mh-letter-mode-syntax-table
 172           (make-syntax-table text-mode-syntax-table))
 173     (modify-syntax-entry ?% "." mh-letter-mode-syntax-table))
 174
 175
 176 ;;;###autoload
 177 (defun mh-smail ()
 178   "Compose and send mail with the MH mail system.
 179 This function is an entry point to mh-e, the Emacs front end
 180 to the MH mail system.
 181
 182 See documentation of `\\[mh-send]' for more details on composing mail."
 183   (interactive)
 184   (mh-find-path)
 185   (call-interactively 'mh-send))
 186
 187
 188 (defvar mh-error-if-no-draft nil)       ;raise error over using old draft
 189
 190
 191 ;;;###autoload
 192 (defun mh-smail-batch ()
 193   "Set up a mail composition draft with the MH mail system.
 194 This function is an entry point to mh-e, the Emacs front end
 195 to the MH mail system.  This function does not prompt the user
 196 for any header fields, and thus is suitable for use by programs
 197 that want to create a mail buffer.
 198 Users should use `\\[mh-smail]' to compose mail."
 199   (mh-find-path)
 200   (let ((mh-error-if-no-draft t))
 201     (mh-send "" "" "")))
 202
 203
 204 (defun mh-edit-again (msg)
 205   "Clean-up a draft or a message previously sent and make it resendable.
 206 Default is the current message.
 207 The variable mh-new-draft-cleaned-headers specifies the headers to remove.
 208 See also documentation for `\\[mh-send]' function."
 209   (interactive (list (mh-get-msg-num t)))
 210   (let* ((from-folder mh-current-folder)
 211          (config (current-window-configuration))
 212          (draft
 213           (cond ((and mh-draft-folder (equal from-folder mh-draft-folder))
 214                  (pop-to-buffer (find-file-noselect (mh-msg-filename msg)) t)
 215                  (rename-buffer (format "draft-%d" msg))
 216                  (buffer-name))
 217                 (t
 218                  (mh-read-draft "clean-up" (mh-msg-filename msg) nil)))))
 219     (mh-clean-msg-header (point-min) mh-new-draft-cleaned-headers nil)
 220     (goto-char (point-min))
 221     (save-buffer)
 222     (mh-compose-and-send-mail draft "" from-folder nil nil nil nil nil nil
 223                               config)))
 224
 225
 226 (defun mh-extract-rejected-mail (msg)
 227   "Extract a letter returned by the mail system and make it resendable.
 228 Default is the current message.  The variable mh-new-draft-cleaned-headers
 229 gives the headers to clean out of the original message.
 230 See also documentation for `\\[mh-send]' function."
 231   (interactive (list (mh-get-msg-num t)))
 232   (let ((from-folder mh-current-folder)
 233         (config (current-window-configuration))
 234         (draft (mh-read-draft "extraction" (mh-msg-filename msg) nil)))
 235     (goto-char (point-min))
 236     (cond ((re-search-forward mh-rejected-letter-start nil t)
 237            (skip-chars-forward " \t\n")
 238            (delete-region (point-min) (point))
 239            (mh-clean-msg-header (point-min) mh-new-draft-cleaned-headers nil))
 240           (t
 241            (message "Does not appear to be a rejected letter.")))
 242     (goto-char (point-min))
 243     (save-buffer)
 244     (mh-compose-and-send-mail draft "" from-folder msg
 245                               (mh-get-header-field "To:")
 246                               (mh-get-header-field "From:")
 247                               (mh-get-header-field "Cc:")
 248                               nil nil config)))
 249
 250
 251 (defun mh-forward (to cc &optional msg-or-seq)
 252   "Forward a message or message sequence.  Defaults to displayed message.
 253 If optional prefix argument provided, then prompt for the message sequence.
 254 See also documentation for `\\[mh-send]' function."
 255   (interactive (list (mh-read-address "To: ")
 256                      (mh-read-address "Cc: ")
 257                      (if current-prefix-arg
 258                          (mh-read-seq-default "Forward" t)
 259                        (mh-get-msg-num t))))
 260   (or msg-or-seq
 261       (setq msg-or-seq (mh-get-msg-num t)))
 262   (let* ((folder mh-current-folder)
 263          (config (current-window-configuration))
 264          ;; forw always leaves file in "draft" since it doesn't have -draft
 265          (draft-name (expand-file-name "draft" mh-user-path))
 266          (draft (cond ((or (not (file-exists-p draft-name))
 267                            (y-or-n-p "The file 'draft' exists.  Discard it? "))
 268                        (mh-exec-cmd "forw" "-build"
 269                                     mh-current-folder msg-or-seq)
 270                        (prog1
 271                            (mh-read-draft "" draft-name t)
 272                          (mh-insert-fields "To:" to "Cc:" cc)
 273                          (save-buffer)))
 274                       (t
 275                        (mh-read-draft "" draft-name nil)))))
 276     (let (orig-from
 277           orig-subject)
 278       (goto-char (point-min))
 279       (re-search-forward "^------- Forwarded Message")
 280       (forward-line 1)
 281       (skip-chars-forward " \t\n")
 282       (save-restriction
 283         (narrow-to-region (point) (point-max))
 284         (setq orig-from (mh-get-header-field "From:"))
 285         (setq orig-subject (mh-get-header-field "Subject:")))
 286       (let ((forw-subject
 287              (mh-forwarded-letter-subject orig-from orig-subject)))
 288         (mh-insert-fields "Subject:" forw-subject)
 289         (goto-char (point-min))
 290         (re-search-forward "^------- Forwarded Message")
 291         (forward-line -1)
 292         (delete-other-windows)
 293         (if (numberp msg-or-seq)
 294             (mh-add-msgs-to-seq msg-or-seq 'forwarded t)
 295           (mh-add-msgs-to-seq (mh-seq-to-msgs msg-or-seq) 'forwarded t))
 296         (mh-compose-and-send-mail draft "" folder msg-or-seq
 297                                   to forw-subject cc
 298                                   mh-note-forw "Forwarded:"
 299                                   config)))))
 300
 301 (defun mh-forwarded-letter-subject (from subject)
 302   ;; Return a Subject suitable for a forwarded message.
 303   ;; Original message has headers FROM and SUBJECT.
 304   (let ((addr-start (string-match "<" from))
 305         (comment (string-match "(" from)))
 306     (cond ((and addr-start (> addr-start 0))
 307            ;; Full Name <luser@host>
 308            (setq from (substring from 0 (1- addr-start))))
 309           (comment
 310            ;; luser@host (Full Name)
 311            (setq from (substring from (1+ comment) (1- (length from)))))))
 312   (format mh-forward-subject-format from subject))
 313
 314
 315 ;;;###autoload
 316 (defun mh-smail-other-window ()
 317   "Compose and send mail in other window with the MH mail system.
 318 This function is an entry point to mh-e, the Emacs front end
 319 to the MH mail system.
 320
 321 See documentation of `\\[mh-send]' for more details on composing mail."
 322   (interactive)
 323   (mh-find-path)
 324   (call-interactively 'mh-send-other-window))
 325
 326
 327 (defun mh-redistribute (to cc &optional msg)
 328   "Redistribute a letter.
 329 Depending on how your copy of MH was compiled, you may need to change the
 330 setting of the variable mh-redist-full-contents.  See its documentation."
 331   (interactive (list (mh-read-address "Redist-To: ")
 332                      (mh-read-address "Redist-Cc: ")
 333                      (mh-get-msg-num t)))
 334   (or msg
 335       (setq msg (mh-get-msg-num t)))
 336   (save-window-excursion
 337     (let ((folder mh-current-folder)
 338           (draft (mh-read-draft "redistribution"
 339                                 (if mh-redist-full-contents
 340                                     (mh-msg-filename msg)
 341                                   nil)
 342                                 nil)))
 343       (mh-goto-header-end 0)
 344       (insert "Resent-To: " to "\n")
 345       (if (not (equal cc "")) (insert "Resent-cc: " cc "\n"))
 346       (mh-clean-msg-header (point-min)
 347                            "^Message-Id:\\|^Received:\\|^Return-Path:\\|^Sender:\\|^Date:\\|^From:"
 348                            nil)
 349       (save-buffer)
 350       (message "Redistributing...")
 351       (if mh-redist-full-contents
 352           (call-process "/bin/sh" nil 0 nil "-c"
 353                         (format "mhdist=1 mhaltmsg=%s %s -push %s"
 354                                 buffer-file-name
 355                                 (expand-file-name mh-send-prog mh-progs)
 356                                 buffer-file-name))
 357         (call-process "/bin/sh" nil 0 nil "-c"
 358                       (format "mhdist=1 mhaltmsg=%s mhannotate=1 %s -push %s"
 359                               (mh-msg-filename msg folder)
 360                               (expand-file-name mh-send-prog mh-progs)
 361                               buffer-file-name)))
 362       (mh-annotate-msg msg folder mh-note-dist
 363                        "-component" "Resent:"
 364                        "-text" (format "\"%s %s\"" to cc))
 365       (kill-buffer draft)
 366       (message "Redistributing...done"))))
 367
 368
 369 (defun mh-reply (message &optional includep)
 370   "Reply to MESSAGE (default: current message).
 371 If optional prefix argument INCLUDEP provided, then include the message
 372 in the reply using filter mhl.reply in your MH directory.
 373 Prompts for type of addresses to reply to:
 374    from    sender only,
 375    to      sender and primary recipients,
 376    cc/all  sender and all recipients.
 377 If the file named by `mh-repl-formfile' exists, it is used as a skeleton
 378 for the reply.  See also documentation for `\\[mh-send]' function."
 379   (interactive (list (mh-get-msg-num t) current-prefix-arg))
 380   (let ((minibuffer-help-form
 381          "from => Sender only\nto => Sender and primary recipients\ncc or all => Sender and all recipients"))
 382     (let ((reply-to (or mh-reply-default-reply-to
 383                         (completing-read "Reply to whom: "
 384                                          '(("from") ("to") ("cc") ("all"))
 385                                          nil
 386                                          t)))
 387           (folder mh-current-folder)
 388           (show-buffer mh-show-buffer)
 389           (config (current-window-configuration)))
 390       (message "Composing a reply...")
 391       (mh-exec-cmd "repl" "-build" "-noquery" "-nodraftfolder"
 392              (if (stringp mh-repl-formfile) ;must be string, but we're paranoid
 393                  (list "-form" mh-repl-formfile))
 394              mh-current-folder message
 395              (cond ((or (equal reply-to "from") (equal reply-to ""))
 396                     '("-nocc" "all"))
 397                    ((equal reply-to "to")
 398                     '("-cc" "to"))
 399                    ((or (equal reply-to "cc") (equal reply-to "all"))
 400                     '("-cc" "all" "-nocc" "me")))
 401              (if includep
 402                  '("-filter" "mhl.reply")))
 403       (let ((draft (mh-read-draft "reply"
 404                                   (expand-file-name "reply" mh-user-path)
 405                                   t)))
 406         (delete-other-windows)
 407         (save-buffer)
 408
 409         (let ((to (mh-get-header-field "To:"))
 410               (subject (mh-get-header-field "Subject:"))
 411               (cc (mh-get-header-field "Cc:")))
 412           (goto-char (point-min))
 413           (mh-goto-header-end 1)
 414           (or includep
 415               (mh-in-show-buffer (show-buffer)
 416                 (mh-display-msg message folder)))
 417           (mh-add-msgs-to-seq message 'answered t)
 418           (message "Composing a reply...done")
 419           (mh-compose-and-send-mail draft "" folder message to subject cc
 420                                     mh-note-repl "Replied:" config))))))
 421
 422
 423 (defun mh-send (to cc subject)
 424   "Compose and send a letter.
 425 The file named by `mh-comp-formfile' will be used as the form.
 426 Do not call this function from outside mh-e; use \\[mh-smail] instead.
 427
 428 The letter is composed in mh-letter-mode; see its documentation for more
 429 details.  If `mh-compose-letter-function' is defined, it is called on the
 430 draft and passed three arguments: to, subject, and cc."
 431   (interactive (list
 432                 (mh-read-address "To: ")
 433                 (mh-read-address "Cc: ")
 434                 (read-string "Subject: ")))
 435   (let ((config (current-window-configuration)))
 436     (delete-other-windows)
 437     (mh-send-sub to cc subject config)))
 438
 439
 440 (defun mh-send-other-window (to cc subject)
 441   "Compose and send a letter in another window.
 442 Do not call this function from outside mh-e;
 443 use \\[mh-smail-other-window] instead.
 444 See also documentation for `\\[mh-send]' function."
 445   (interactive (list
 446                 (mh-read-address "To: ")
 447                 (mh-read-address "Cc: ")
 448                 (read-string "Subject: ")))
 449   (let ((pop-up-windows t))
 450     (mh-send-sub to cc subject (current-window-configuration))))
 451
 452
 453 (defun mh-send-sub (to cc subject config)
 454   ;; Do the real work of composing and sending a letter.
 455   ;; Expects the TO, CC, and SUBJECT fields as arguments.
 456   ;; CONFIG is the window configuration before sending mail.
 457   (let ((folder mh-current-folder)
 458         (msg-num (mh-get-msg-num nil)))
 459     (message "Composing a message...")
 460     (let ((draft (mh-read-draft
 461                   "message"
 462                   (let (components)
 463                     (cond
 464                      ((file-exists-p
 465                        (setq components
 466                              (expand-file-name mh-comp-formfile mh-user-path)))
 467                       components)
 468                      ((file-exists-p
 469                        (setq components
 470                              (expand-file-name mh-comp-formfile mh-lib)))
 471                       components)
 472                      (t
 473                       (error (format "Can't find components file \"%s\""
 474                                      components)))))
 475                   nil)))
 476       (mh-insert-fields "To:" to "Subject:" subject "Cc:" cc)
 477       (goto-char (point-max))
 478       (message "Composing a message...done")
 479       (mh-compose-and-send-mail draft "" folder msg-num
 480                                 to subject cc
 481                                 nil nil config))))
 482
 483
 484 (defun mh-read-draft (use initial-contents delete-contents-file)
 485   ;; Read draft file into a draft buffer and make that buffer the current one.
 486   ;; USE is a message used for prompting about the intended use of the message.
 487   ;; INITIAL-CONTENTS is filename that is read into an empty buffer, or NIL
 488   ;; if buffer should not be modified.  Delete the initial-contents file if
 489   ;; DELETE-CONTENTS-FILE flag is set.
 490   ;; Returns the draft folder's name.
 491   ;; If the draft folder facility is enabled in ~/.mh_profile, a new buffer is
 492   ;; used each time and saved in the draft folder.  The draft file can then be
 493   ;; reused.
 494   (cond (mh-draft-folder
 495          (let ((orig-default-dir default-directory)
 496                (draft-file-name (mh-new-draft-name)))
 497            (pop-to-buffer (generate-new-buffer
 498                            (format "draft-%s"
 499                                    (file-name-nondirectory draft-file-name))))
 500            (condition-case ()
 501                (insert-file-contents draft-file-name t)
 502              (file-error))
 503            (setq default-directory orig-default-dir)))
 504         (t
 505          (let ((draft-name (expand-file-name "draft" mh-user-path)))
 506            (pop-to-buffer "draft")      ; Create if necessary
 507            (if (buffer-modified-p)
 508                (if (y-or-n-p "Draft has been modified; kill anyway? ")
 509                    (set-buffer-modified-p nil)
 510                    (error "Draft preserved")))
 511            (setq buffer-file-name draft-name)
 512            (clear-visited-file-modtime)
 513            (unlock-buffer)
 514            (cond ((and (file-exists-p draft-name)
 515                        (not (equal draft-name initial-contents)))
 516                   (insert-file-contents draft-name)
 517                   (delete-file draft-name))))))
 518   (cond ((and initial-contents
 519               (or (zerop (buffer-size))
 520                   (if (y-or-n-p
 521                         (format "A draft exists.  Use for %s? " use))
 522                       (if mh-error-if-no-draft
 523                           (error "A prior draft exists."))
 524                     t)))
 525          (erase-buffer)
 526          (insert-file-contents initial-contents)
 527          (if delete-contents-file (delete-file initial-contents))))
 528   (auto-save-mode 1)
 529   (if mh-draft-folder
 530       (save-buffer))                    ; Do not reuse draft name
 531   (buffer-name))
 532
 533
 534 (defun mh-new-draft-name ()
 535   ;; Returns the pathname of folder for draft messages.
 536   (save-excursion
 537     (mh-exec-cmd-quiet t "mhpath" mh-draft-folder "new")
 538     (buffer-substring (point-min) (1- (point-max)))))
 539
 540
 541 (defun mh-annotate-msg (msg buffer note &rest args)
 542   ;; Mark the MESSAGE in BUFFER listing with the character NOTE and annotate
 543   ;; the saved message with ARGS.
 544   (apply 'mh-exec-cmd "anno" buffer msg args)
 545   (save-excursion
 546     (cond ((get-buffer buffer)          ; Buffer may be deleted
 547            (set-buffer buffer)
 548            (if (symbolp msg)
 549                (mh-notate-seq msg note (1+ mh-cmd-note))
 550                (mh-notate msg note (1+ mh-cmd-note)))))))
 551
 552
 553 (defun mh-insert-fields (&rest name-values)
 554   ;; Insert the NAME-VALUE pairs in the current buffer.
 555   ;; If field NAME exists, append VALUE to it.
 556   ;; Do not insert any pairs whose value is the empty string.
 557   (let ((case-fold-search t))
 558     (while name-values
 559       (let ((field-name (car name-values))
 560             (value (car (cdr name-values))))
 561         (cond ((equal value "")
 562                nil)
 563               ((mh-position-on-field field-name)
 564                (insert " " value))
 565               (t
 566                (insert field-name " " value "\n")))
 567         (setq name-values (cdr (cdr name-values)))))))
 568
 569
 570 (defun mh-position-on-field (field &optional ignore)
 571   ;; Move to the end of the FIELD in the header.
 572   ;; Move to end of entire header if FIELD not found.
 573   ;; Returns non-nil iff FIELD was found.
 574   ;; The optional second arg is for pre-version 4 compatibility.
 575   (if (mh-goto-header-field field)
 576       (progn
 577         (mh-header-field-end)
 578         t)))
 579
 580
 581 (defun mh-get-header-field (field)
 582   ;; Find and return the body of FIELD in the mail header.
 583   ;; Returns the empty string if the field is not in the header of the
 584   ;; current buffer.
 585   (if (mh-goto-header-field field)
 586       (progn
 587         (skip-chars-forward " \t")      ;strip leading white space in body
 588         (let ((start (point)))
 589           (mh-header-field-end)
 590           (buffer-substring start (point))))
 591     ""))
 592
 593 (fset 'mh-get-field 'mh-get-header-field) ;mh-e 4 compatibility
 594
 595 (defun mh-goto-header-field (field)
 596   ;; Move to FIELD in the message header.
 597   ;; Move to the end of the FIELD name, which should end in a colon.
 598   ;; Returns T if found, NIL if not.
 599   (goto-char (point-min))
 600   (let ((case-fold-search t)
 601         (headers-end (save-excursion
 602                       (mh-goto-header-end 0)
 603                       (point))))
 604     (re-search-forward (format "^%s" field) headers-end t)))
 605
 606 (defun mh-header-field-end ()
 607   ;; Move to the end of the current header field.
 608   ;; Handles RFC 822 continuation lines.
 609   (forward-line 1)
 610   (while (looking-at "^[ \t]")
 611     (forward-line 1))
 612   (backward-char 1))            ;to end of previous line
 613
 614
 615 (defun mh-goto-header-end (arg)
 616   ;; Find the end of the message header in the current buffer and position
 617   ;; the cursor at the ARG'th newline after the header.
 618   (if (re-search-forward "^-*$" nil nil)
 619       (forward-line arg)))
 620
 621
 622 (defun mh-read-address (prompt)
 623   ;; Read a To: or Cc: address, prompting in the minibuffer with PROMPT.
 624   ;; May someday do completion on aliases.
 625   (read-string prompt))
 626
 627 \f
 628
 629 ;;; Mode for composing and sending a draft message.
 630
 631 (defvar mh-sent-from-folder nil)        ;Folder of msg assoc with this letter.
 632
 633 (defvar mh-sent-from-msg nil)           ;Number of msg assoc with this letter.
 634
 635 (defvar mh-send-args nil)               ;Extra args to pass to "send" command.
 636
 637 (defvar mh-annotate-char nil)           ;Character to use to annotate mh-sent-from-msg.
 638
 639 (defvar mh-annotate-field nil)          ;Field name for message annotation.
 640
 641 (put 'mh-letter-mode 'mode-class 'special)
 642
 643 ;;;###autoload
 644 (defun mh-letter-mode ()
 645   "Mode for composing letters in mh-e.\\<mh-letter-mode-map>
 646 When you have finished composing, type \\[mh-send-letter] to send the message
 647 using the MH mail handling system.
 648 See the documentation for \\[mh-edit-mhn] for information on composing MIME
 649 messages.
 650
 651 \\{mh-letter-mode-map}
 652
 653 Variables controlling this mode (defaults in parentheses):
 654
 655  mh-delete-yanked-msg-window (nil)
 656     If non-nil, \\[mh-yank-cur-msg] will delete any windows displaying
 657     the yanked message.
 658
 659  mh-yank-from-start-of-msg (t)
 660     If non-nil, \\[mh-yank-cur-msg] will include the entire message.
 661     If `body', just yank the body (no header).
 662     If nil, only the portion of the message following the point will be yanked.
 663     If there is a region, this variable is ignored.
 664
 665  mh-ins-buf-prefix (\"> \")
 666     String to insert before each non-blank line of a message as it is
 667     inserted in a draft letter.
 668
 669  mh-signature-file-name (\"~/.signature\")
 670     File to be inserted into message by \\[mh-insert-signature].
 671
 672 Upon invoking mh-letter-mode, text-mode-hook and mh-letter-mode-hook are
 673 invoked with no args, if those values are non-nil."
 674
 675   (interactive)
 676   (or mh-user-path (mh-find-path))
 677   (make-local-variable 'paragraph-start)
 678   (setq paragraph-start (concat "^[ \t]*[-_][-_][-_]+$\\|" paragraph-start))
 679   (make-local-variable 'paragraph-separate)
 680   (setq paragraph-separate
 681         (concat "^[ \t]*[-_][-_][-_]+$\\|" paragraph-separate))
 682   (make-local-variable 'mh-send-args)
 683   (make-local-variable 'mh-annotate-char)
 684   (make-local-variable 'mh-annotate-field)
 685   (make-local-variable 'mh-previous-window-config)
 686   (make-local-variable 'mh-sent-from-folder)
 687   (make-local-variable 'mh-sent-from-msg)
 688   (make-local-variable 'mail-header-separator)
 689   (setq mail-header-separator "--------") ;for Hyperbole
 690   (use-local-map mh-letter-mode-map)
 691   (setq major-mode 'mh-letter-mode)
 692   (mh-set-mode-name "MH-Letter")
 693   (set-syntax-table mh-letter-mode-syntax-table)
 694   (run-hooks 'text-mode-hook)
 695   ;; if text-mode-hook turned on auto-fill, tune it for messages
 696   (cond ((and (boundp 'auto-fill-hook) auto-fill-hook) ;emacs 18
 697          (make-local-variable 'auto-fill-hook)
 698          (setq auto-fill-hook 'mh-auto-fill-for-letter)))
 699   (cond ((and (boundp 'auto-fill-function) auto-fill-function) ;emacs 19
 700          (make-local-variable 'auto-fill-function)
 701          (setq auto-fill-function 'mh-auto-fill-for-letter)))
 702   (run-hooks 'mh-letter-mode-hook))
 703
 704
 705 (defun mh-auto-fill-for-letter ()
 706   ;; Auto-fill in letters treats the header specially by inserting a tab
 707   ;; before continuation line.
 708   (if (mh-in-header-p)
 709       (let ((fill-prefix "\t"))
 710         (do-auto-fill))
 711     (do-auto-fill)))
 712
 713
 714 (defun mh-in-header-p ()
 715   ;; Return non-nil if the point is in the header of a draft message.
 716   (save-excursion
 717     (let ((cur-point (point)))
 718       (goto-char (point-min))
 719       (re-search-forward "^-*$" nil t)
 720       (< cur-point (point)))))
 721
 722
 723 (defun mh-to-field ()
 724   "Move point to the end of a specified header field.
 725 The field is indicated by the previous keystroke (the last keystroke
 726 of the command) according to the list in the variable mh-to-field-choices.
 727 Create the field if it does not exist.  Set the mark to point before moving."
 728   (interactive)
 729   (expand-abbrev)
 730   (let ((target (cdr (or (assoc (char-to-string (logior last-input-char ?`))
 731                                 mh-to-field-choices)
 732                          ;; also look for a char for version 4 compat
 733                          (assoc (logior last-input-char ?`) mh-to-field-choices))))
 734         (case-fold-search t))
 735     (push-mark)
 736     (cond ((mh-position-on-field target)
 737            (let ((eol (point)))
 738              (skip-chars-backward " \t")
 739              (delete-region (point) eol))
 740            (if (and (not (eq (logior last-input-char ?`) ?s))
 741                     (save-excursion
 742                       (backward-char 1)
 743                       (not (looking-at "[:,]"))))
 744                (insert ", ")
 745                (insert " ")))
 746           (t
 747            (if (mh-position-on-field "To:")
 748                (forward-line 1))
 749            (insert (format "%s \n" target))
 750            (backward-char 1)))))
 751
 752
 753 (defun mh-to-fcc (&optional folder)
 754   "Insert an Fcc: FOLDER field in the current message.
 755 Prompt for the field name with a completion list of the current folders."
 756   (interactive)
 757   (or folder
 758       (setq folder (mh-prompt-for-folder
 759                     "Fcc"
 760                     (or (and mh-default-folder-for-message-function
 761                              (save-excursion
 762                                (goto-char (point-min))
 763                                (funcall mh-default-folder-for-message-function)))
 764                         "")
 765                     t)))
 766   (let ((last-input-char ?\C-f))
 767     (expand-abbrev)
 768     (save-excursion
 769       (mh-to-field)
 770       (insert (if (mh-folder-name-p folder)
 771                   (substring folder 1)
 772                 folder)))))
 773
 774
 775 (defun mh-insert-signature ()
 776   "Insert the file named by mh-signature-file-name at the current point."
 777   (interactive)
 778   (insert-file-contents mh-signature-file-name)
 779   (force-mode-line-update))
 780
 781
 782 (defun mh-check-whom ()
 783   "Verify recipients of the current letter, showing expansion of any aliases."
 784   (interactive)
 785   (let ((file-name buffer-file-name))
 786     (save-buffer)
 787     (message "Checking recipients...")
 788     (mh-in-show-buffer ("*Recipients*")
 789       (bury-buffer (current-buffer))
 790       (erase-buffer)
 791       (mh-exec-cmd-output "whom" t file-name))
 792     (message "Checking recipients...done")))
 793
 794 \f
 795
 796 ;;; Routines to compose and send a letter.
 797
 798 (defun mh-compose-and-send-mail (draft send-args
 799                                        sent-from-folder sent-from-msg
 800                                        to subject cc
 801                                        annotate-char annotate-field
 802                                        config)
 803   ;; Edit and compose a draft message in buffer DRAFT and send or save it.
 804   ;; SENT-FROM-FOLDER is buffer containing scan listing of current folder, or
 805   ;; nil if none exists.
 806   ;; SENT-FROM-MSG is the message number or sequence name or nil.
 807   ;; SEND-ARGS is an optional argument passed to the send command.
 808   ;; The TO, SUBJECT, and CC fields are passed to the
 809   ;; mh-compose-letter-function.
 810   ;; If ANNOTATE-CHAR is non-null, it is used to notate the scan listing of the
 811   ;; message.  In that case, the ANNOTATE-FIELD is used to build a string
 812   ;; for mh-annotate-msg.
 813   ;; CONFIG is the window configuration to restore after sending the letter.
 814   (pop-to-buffer draft)
 815   (mh-letter-mode)
 816   (setq mh-sent-from-folder sent-from-folder)
 817   (setq mh-sent-from-msg sent-from-msg)
 818   (setq mh-send-args send-args)
 819   (setq mh-annotate-char annotate-char)
 820   (setq mh-annotate-field annotate-field)
 821   (setq mh-previous-window-config config)
 822   (setq mode-line-buffer-identification (list "{%b}"))
 823   (if (and (boundp 'mh-compose-letter-function)
 824            mh-compose-letter-function)
 825       ;; run-hooks will not pass arguments.
 826       (let ((value mh-compose-letter-function))
 827         (if (and (listp value) (not (eq (car value) 'lambda)))
 828             (while value
 829               (funcall (car value) to subject cc)
 830               (setq value (cdr value)))
 831             (funcall mh-compose-letter-function to subject cc)))))
 832
 833
 834 (defun mh-send-letter (&optional arg)
 835   "Send the draft letter in the current buffer.
 836 If optional prefix argument is provided, monitor delivery.
 837 Run mh-before-send-letter-hook before doing anything."
 838   (interactive "P")
 839   (run-hooks 'mh-before-send-letter-hook)
 840   (save-buffer)
 841   (message "Sending...")
 842   (let ((draft-buffer (current-buffer))
 843         (file-name buffer-file-name)
 844         (config mh-previous-window-config))
 845     (cond (arg
 846            (pop-to-buffer "MH mail delivery")
 847            (erase-buffer)
 848            (mh-exec-cmd-output mh-send-prog t "-watch" "-nopush"
 849                                "-nodraftfolder" mh-send-args file-name)
 850            (goto-char (point-max))      ; show the interesting part
 851            (recenter -1)
 852            (set-buffer draft-buffer))   ; for annotation below
 853           (t
 854            (mh-exec-cmd-daemon mh-send-prog "-nodraftfolder" "-noverbose"
 855                                mh-send-args file-name)))
 856     (if mh-annotate-char
 857         (mh-annotate-msg mh-sent-from-msg
 858                          mh-sent-from-folder
 859                          mh-annotate-char
 860                          "-component" mh-annotate-field
 861                          "-text" (format "\"%s %s\""
 862                                          (mh-get-header-field "To:")
 863                                          (mh-get-header-field "Cc:"))))
 864
 865     (cond ((or (not arg)
 866                (y-or-n-p "Kill draft buffer? "))
 867            (kill-buffer draft-buffer)
 868            (if config
 869                (set-window-configuration config))))
 870     (if arg
 871         (message "Sending...done")
 872       (message "Sending...backgrounded"))))
 873
 874
 875 (defun mh-insert-letter (folder message verbatim)
 876   "Insert a message into the current letter.
 877 Removes the message's headers using mh-invisible-headers.  Prefixes
 878 each non-blank line with mh-ins-buf-prefix.  Prompts for FOLDER and
 879 MESSAGE.  If prefix argument VERBATIM provided, do not indent and do
 880 not delete headers.  Leaves the mark before the letter and point after it."
 881   (interactive
 882    (list (mh-prompt-for-folder "Message from" mh-sent-from-folder nil)
 883          (read-input (format "Message number%s: "
 884                              (if mh-sent-from-msg
 885                                  (format " [%d]" mh-sent-from-msg)
 886                                "")))
 887          current-prefix-arg))
 888   (save-restriction
 889     (narrow-to-region (point) (point))
 890     (let ((start (point-min)))
 891       (if (equal message "") (setq message (int-to-string mh-sent-from-msg)))
 892       (mh-exec-lib-cmd-output "mhl" "-nobell" "-noclear"
 893                               (expand-file-name message
 894                                                 (mh-expand-file-name folder)))
 895       (cond ((not verbatim)
 896              (mh-clean-msg-header start mh-invisible-headers mh-visible-headers)
 897              (set-mark start)           ; since mh-clean-msg-header moves it
 898              (mh-insert-prefix-string mh-ins-buf-prefix))))))
 899
 900
 901 (defun mh-yank-cur-msg ()
 902   "Insert the current message into the draft buffer.
 903 Prefix each non-blank line in the message with the string in
 904 `mh-ins-buf-prefix'.  If a region is set in the message's buffer, then
 905 only the region will be inserted.  Otherwise, the entire message will
 906 be inserted if `mh-yank-from-start-of-msg' is non-nil.  If this variable
 907 is nil, the portion of the message following the point will be yanked.
 908 If `mh-delete-yanked-msg-window' is non-nil, any window displaying the
 909 yanked message will be deleted."
 910   (interactive)
 911   (if (and mh-sent-from-folder mh-sent-from-msg)
 912       (let ((to-point (point))
 913             (to-buffer (current-buffer)))
 914         (set-buffer mh-sent-from-folder)
 915         (if mh-delete-yanked-msg-window
 916             (delete-windows-on mh-show-buffer))
 917         (set-buffer mh-show-buffer)     ; Find displayed message
 918         (let ((mh-ins-str (cond ((if (boundp 'mark-active)
 919                                      mark-active ;Emacs 19
 920                                    (mark)) ;Emacs 18
 921                                  (buffer-substring (region-beginning)
 922                                                    (region-end)))
 923                                 ((eq 'body mh-yank-from-start-of-msg)
 924                                  (buffer-substring
 925                                   (save-excursion
 926                                     (goto-char (point-min))
 927                                     (mh-goto-header-end 1)
 928                                     (point))
 929                                   (point-max)))
 930                                 (mh-yank-from-start-of-msg
 931                                  (buffer-substring (point-min) (point-max)))
 932                                 (t
 933                                  (buffer-substring (point) (point-max))))))
 934           (set-buffer to-buffer)
 935           (save-restriction
 936             (narrow-to-region to-point to-point)
 937             (push-mark)
 938             (insert mh-ins-str)
 939             (mh-insert-prefix-string mh-ins-buf-prefix)
 940             (insert "\n"))))
 941     (error "There is no current message")))
 942
 943
 944 (defun mh-insert-prefix-string (mh-ins-string)
 945   ;; Run mail-citation-hook to insert a prefix string before each line
 946   ;; in the buffer.  Generality for supercite users.
 947   (set-mark (point-max))
 948   (goto-char (point-min))
 949   (cond (mail-citation-hook
 950          (run-hooks 'mail-citation-hook))
 951         (mh-yank-hooks                  ;old hook name
 952          (run-hooks 'mh-yank-hooks))
 953         (t
 954          (or (bolp) (forward-line 1))
 955          (let ((zmacs-regions nil))     ;so "(mark)" works in XEmacs
 956            (while (< (point) (mark))
 957              (insert mh-ins-string)
 958              (forward-line 1))))))
 959
 960
 961 (defun mh-fully-kill-draft ()
 962   "Kill the draft message file and the draft message buffer.
 963 Use \\[kill-buffer] if you don't want to delete the draft message file."
 964   (interactive)
 965   (if (y-or-n-p "Kill draft message? ")
 966       (let ((config mh-previous-window-config))
 967         (if (file-exists-p buffer-file-name)
 968             (delete-file buffer-file-name))
 969         (set-buffer-modified-p nil)
 970         (kill-buffer (buffer-name))
 971         (message "")
 972         (if config
 973             (set-window-configuration config)))
 974     (error "Message not killed")))
 975
 976
 977 ;;; Build the letter-mode keymap:
 978
 979 (define-key mh-letter-mode-map "\C-c\C-f\C-b" 'mh-to-field)
 980 (define-key mh-letter-mode-map "\C-c\C-f\C-c" 'mh-to-field)
 981 (define-key mh-letter-mode-map "\C-c\C-f\C-d" 'mh-to-field)
 982 (define-key mh-letter-mode-map "\C-c\C-f\C-f" 'mh-to-fcc)
 983 (define-key mh-letter-mode-map "\C-c\C-f\C-r" 'mh-to-field)
 984 (define-key mh-letter-mode-map "\C-c\C-f\C-s" 'mh-to-field)
 985 (define-key mh-letter-mode-map "\C-c\C-f\C-t" 'mh-to-field)
 986 (define-key mh-letter-mode-map "\C-c\C-fb" 'mh-to-field)
 987 (define-key mh-letter-mode-map "\C-c\C-fc" 'mh-to-field)
 988 (define-key mh-letter-mode-map "\C-c\C-fd" 'mh-to-field)
 989 (define-key mh-letter-mode-map "\C-c\C-ff" 'mh-to-fcc)
 990 (define-key mh-letter-mode-map "\C-c\C-fr" 'mh-to-field)
 991 (define-key mh-letter-mode-map "\C-c\C-fs" 'mh-to-field)
 992 (define-key mh-letter-mode-map "\C-c\C-ft" 'mh-to-field)
 993 (define-key mh-letter-mode-map "\C-c\C-i" 'mh-insert-letter)
 994 (define-key mh-letter-mode-map "\C-c\C-q" 'mh-fully-kill-draft)
 995 (define-key mh-letter-mode-map "\C-c\C-\\" 'mh-fully-kill-draft) ;if no C-q
 996 (define-key mh-letter-mode-map "\C-c\C-s" 'mh-insert-signature)
 997 (define-key mh-letter-mode-map "\C-c\C-^" 'mh-insert-signature) ;if no C-s
 998 (define-key mh-letter-mode-map "\C-c\C-w" 'mh-check-whom)
 999 (define-key mh-letter-mode-map "\C-c\C-y" 'mh-yank-cur-msg)
1000 (define-key mh-letter-mode-map "\C-c\C-c" 'mh-send-letter)
1001 (define-key mh-letter-mode-map "\C-c\C-m\C-f" 'mh-mhn-compose-forw)
1002 (define-key mh-letter-mode-map "\C-c\C-m\C-e" 'mh-mhn-compose-anon-ftp)
1003 (define-key mh-letter-mode-map "\C-c\C-m\C-t" 'mh-mhn-compose-external-compressed-tar)
1004 (define-key mh-letter-mode-map "\C-c\C-m\C-i" 'mh-mhn-compose-insertion)
1005 (define-key mh-letter-mode-map "\C-c\C-e" 'mh-edit-mhn)
1006 (define-key mh-letter-mode-map "\C-c\C-m\C-u" 'mh-revert-mhn-edit)
1007
1008 ;; "C-c /" prefix is used in mh-letter-mode by pgp.el
1009
1010 ;;; autoloads from mh-mime
1011
1012 (autoload 'mh-mhn-compose-insertion "mh-mime"
1013   "Add a directive to insert a MIME message part from a file.
1014 This is the typical way to insert non-text parts in a message.
1015 See also \\[mh-edit-mhn]." t)
1016
1017 (autoload 'mh-mhn-compose-anon-ftp "mh-mime"
1018   "Add a directive for a MIME anonymous ftp external body part.
1019 This directive tells MH to include a reference to a
1020 message/external-body part retrievable by anonymous FTP.
1021 See also \\[mh-edit-mhn]." t)
1022
1023 (autoload 'mh-mhn-compose-external-compressed-tar "mh-mime"
1024   "Add a directive to include a MIME reference to a compressed tar file.
1025 The file should be available via anonymous ftp.  This directive
1026 tells MH to include a reference to a message/external-body part.
1027 See also \\[mh-edit-mhn]." t)
1028
1029 (autoload 'mh-mhn-compose-forw "mh-mime"
1030   "Add a forw directive to this message, to forward a message with MIME.
1031 This directive tells MH to include another message in this one.
1032 See also \\[mh-edit-mhn]." t)
1033
1034 (autoload 'mh-edit-mhn "mh-mime"
1035   "Format the current draft for MIME, expanding any mhn directives.
1036 Process the current draft with the mhn program, which,
1037 using directives already inserted in the draft, fills in
1038 all the MIME components and header fields.
1039 This step should be done last just before sending the message.
1040 The mhn program is part of MH version 6.8 or later.
1041 The `\\[mh-revert-mhn-edit]' command undoes this command.
1042 For assistance with creating mhn directives to insert
1043 various types of components in a message, see
1044 \\[mh-mhn-compose-insertion] (generic insertion from a file),
1045 \\[mh-mhn-compose-anon-ftp] (external reference to file via anonymous ftp),
1046 \\[mh-mhn-compose-external-compressed-tar] \
1047 \(reference to compressed tar file via anonymous ftp), and
1048 \\[mh-mhn-compose-forw] (forward message)." t)
1049
1050 (autoload 'mh-revert-mhn-edit "mh-mime"
1051   "Undoes the effect of \\[mh-edit-mhn] by reverting to the backup file.
1052 Optional non-nil argument means don't ask for confirmation." t)