lisp/mh-e/mh-letter.el

   1 ;;; mh-letter.el --- MH-Letter mode
   2
   3 ;; Copyright (C) 1993, 1995, 1997,
   4 ;;  2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 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 3, 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., 51 Franklin Street, Fifth Floor,
  26 ;; Boston, MA 02110-1301, USA.
  27
  28 ;;; Commentary:
  29
  30 ;; Mode for composing and sending a draft message.
  31
  32 ;; Functions that would ordinarily be in here that are needed by
  33 ;; mh-show.el should be placed in the Message Utilities section in
  34 ;; mh-utils.el. That will help prevent the loading of this file until
  35 ;; a message is actually composed.
  36
  37 ;;; Change Log:
  38
  39 ;;; Code:
  40
  41 (require 'mh-e)
  42
  43 (require 'gnus-util)
  44
  45 ;; Dynamically-created functions not found in mh-loaddefs.el.
  46 (autoload 'mh-tool-bar-letter-buttons-init "mh-tool-bar")
  47 (autoload 'mh-tool-bar-init "mh-tool-bar")
  48
  49 (autoload 'mml-insert-tag "mml")
  50
  51 ;;; Variables
  52
  53 (defvar mh-letter-complete-function-alist
  54   '((bcc . mh-alias-letter-expand-alias)
  55     (cc . mh-alias-letter-expand-alias)
  56     (dcc . mh-alias-letter-expand-alias)
  57     (fcc . mh-folder-expand-at-point)
  58     (from . mh-alias-letter-expand-alias)
  59     (mail-followup-to . mh-alias-letter-expand-alias)
  60     (mail-reply-to . mh-alias-letter-expand-alias)
  61     (reply-to . mh-alias-letter-expand-alias)
  62     (to . mh-alias-letter-expand-alias))
  63   "Alist of header fields and completion functions to use.")
  64
  65 (defvar mh-yank-hooks nil
  66   "Obsolete hook for modifying a citation just inserted in the mail buffer.
  67
  68 Each hook function can find the citation between point and mark.
  69 And each hook function should leave point and mark around the
  70 citation text as modified.
  71
  72 This is a normal hook, misnamed for historical reasons. It is
  73 semi-obsolete and is only used if `mail-citation-hook' is nil.")
  74
  75 \f
  76
  77 ;;; Letter Menu
  78
  79 (easy-menu-define
  80   mh-letter-menu mh-letter-mode-map "Menu for MH-E letter mode."
  81   '("Letter"
  82     ["Send This Draft"          mh-send-letter t]
  83     ["Split Current Line"       mh-open-line t]
  84     ["Check Recipient"          mh-check-whom t]
  85     ["Yank Current Message"     mh-yank-cur-msg t]
  86     ["Insert a Message..."      mh-insert-letter t]
  87     ["Insert Signature"         mh-insert-signature t]
  88     ("Encrypt/Sign Message"
  89      ["Sign Message"
  90       mh-mml-secure-message-sign mh-pgp-support-flag]
  91      ["Encrypt Message"
  92       mh-mml-secure-message-encrypt mh-pgp-support-flag]
  93      ["Sign+Encrypt Message"
  94       mh-mml-secure-message-signencrypt mh-pgp-support-flag]
  95      ["Disable Security"
  96       mh-mml-unsecure-message mh-pgp-support-flag]
  97      "--"
  98      "Security Method"
  99      ["PGP (MIME)" (setq mh-mml-method-default "pgpmime")
 100       :style radio
 101       :selected (equal mh-mml-method-default "pgpmime")]
 102      ["PGP" (setq mh-mml-method-default "pgp")
 103       :style radio
 104       :selected (equal mh-mml-method-default "pgp")]
 105      ["S/MIME" (setq mh-mml-method-default "smime")
 106       :style radio
 107       :selected (equal mh-mml-method-default "smime")]
 108      "--"
 109      ["Save Method as Default"
 110       (customize-save-variable 'mh-mml-method-default mh-mml-method-default) t]
 111      )
 112     ["Compose Insertion..."      mh-compose-insertion t]
 113     ["Compose Compressed tar (MH)..."
 114      mh-mh-compose-external-compressed-tar t]
 115     ["Compose Get File (MH)..."       mh-mh-compose-anon-ftp t]
 116     ["Compose Forward..."        mh-compose-forward t]
 117     ;; The next two will have to be merged. But I also need to make sure the
 118     ;; user can't mix tags of both types.
 119     ["Pull in All Compositions (MH)"
 120      mh-mh-to-mime (mh-mh-directive-present-p)]
 121     ["Pull in All Compositions (MML)"
 122      mh-mml-to-mime (mh-mml-tag-present-p)]
 123     ["Revert to Non-MIME Edit (MH)"
 124      mh-mh-to-mime-undo (equal mh-compose-insertion 'mh)]
 125     ["Kill This Draft"          mh-fully-kill-draft t]))
 126
 127 \f
 128
 129 ;;; MH-Letter Keys
 130
 131 ;; If this changes, modify mh-letter-mode-help-messages accordingly, above.
 132 (gnus-define-keys  mh-letter-mode-map
 133   " "                   mh-letter-complete-or-space
 134   ","                   mh-letter-confirm-address
 135   "\C-c?"               mh-help
 136   "\C-c\C-\\"           mh-fully-kill-draft ;if no C-q
 137   "\C-c\C-^"            mh-insert-signature ;if no C-s
 138   "\C-c\C-c"            mh-send-letter
 139   "\C-c\C-d"            mh-insert-identity
 140   "\C-c\C-e"            mh-mh-to-mime
 141   "\C-c\C-f\C-a"        mh-to-field
 142   "\C-c\C-f\C-b"        mh-to-field
 143   "\C-c\C-f\C-c"        mh-to-field
 144   "\C-c\C-f\C-d"        mh-to-field
 145   "\C-c\C-f\C-f"        mh-to-fcc
 146   "\C-c\C-f\C-l"        mh-to-field
 147   "\C-c\C-f\C-m"        mh-to-field
 148   "\C-c\C-f\C-r"        mh-to-field
 149   "\C-c\C-f\C-s"        mh-to-field
 150   "\C-c\C-f\C-t"        mh-to-field
 151   "\C-c\C-fa"           mh-to-field
 152   "\C-c\C-fb"           mh-to-field
 153   "\C-c\C-fc"           mh-to-field
 154   "\C-c\C-fd"           mh-to-field
 155   "\C-c\C-ff"           mh-to-fcc
 156   "\C-c\C-fl"           mh-to-field
 157   "\C-c\C-fm"           mh-to-field
 158   "\C-c\C-fr"           mh-to-field
 159   "\C-c\C-fs"           mh-to-field
 160   "\C-c\C-ft"           mh-to-field
 161   "\C-c\C-i"            mh-insert-letter
 162   "\C-c\C-m\C-e"        mh-mml-secure-message-encrypt
 163   "\C-c\C-m\C-f"        mh-compose-forward
 164   "\C-c\C-m\C-g"        mh-mh-compose-anon-ftp
 165   "\C-c\C-m\C-i"        mh-compose-insertion
 166   "\C-c\C-m\C-m"        mh-mml-to-mime
 167   "\C-c\C-m\C-n"        mh-mml-unsecure-message
 168   "\C-c\C-m\C-s"        mh-mml-secure-message-sign
 169   "\C-c\C-m\C-t"        mh-mh-compose-external-compressed-tar
 170   "\C-c\C-m\C-u"        mh-mh-to-mime-undo
 171   "\C-c\C-m\C-x"        mh-mh-compose-external-type
 172   "\C-c\C-mee"          mh-mml-secure-message-encrypt
 173   "\C-c\C-mes"          mh-mml-secure-message-signencrypt
 174   "\C-c\C-mf"           mh-compose-forward
 175   "\C-c\C-mg"           mh-mh-compose-anon-ftp
 176   "\C-c\C-mi"           mh-compose-insertion
 177   "\C-c\C-mm"           mh-mml-to-mime
 178   "\C-c\C-mn"           mh-mml-unsecure-message
 179   "\C-c\C-mse"          mh-mml-secure-message-signencrypt
 180   "\C-c\C-mss"          mh-mml-secure-message-sign
 181   "\C-c\C-mt"           mh-mh-compose-external-compressed-tar
 182   "\C-c\C-mu"           mh-mh-to-mime-undo
 183   "\C-c\C-mx"           mh-mh-compose-external-type
 184   "\C-c\C-o"            mh-open-line
 185   "\C-c\C-q"            mh-fully-kill-draft
 186   "\C-c\C-s"            mh-insert-signature
 187   "\C-c\C-t"            mh-letter-toggle-header-field-display
 188   "\C-c\C-w"            mh-check-whom
 189   "\C-c\C-y"            mh-yank-cur-msg
 190   "\C-c\M-d"            mh-insert-auto-fields
 191   "\M-\t"               mh-letter-complete
 192   "\t"                  mh-letter-next-header-field-or-indent
 193   [backtab]             mh-letter-previous-header-field)
 194
 195 ;; "C-c /" prefix is used in mh-letter-mode by pgp.el and mailcrypt.el.
 196
 197 \f
 198
 199 ;;; MH-Letter Help Messages
 200
 201 ;; Group messages logically, more or less.
 202 (defvar mh-letter-mode-help-messages
 203   '((nil
 204      "Send letter: \\[mh-send-letter]    "
 205      "Open line:        \\[mh-open-line]\n"
 206      "Kill letter: \\[mh-fully-kill-draft]    "
 207      "Check recipients: \\[mh-check-whom]\n\n"
 208      "Insert:\n"
 209      "  Current message:      \\[mh-yank-cur-msg]\n"
 210      "  Attachment:           \\[mh-compose-insertion]\n"
 211      "  Message to forward:   \\[mh-compose-forward]\n"
 212      "  Signature:            \\[mh-insert-signature]\n\n"
 213      "Security:\n"
 214      "  Encrypt message:      \\[mh-mml-secure-message-encrypt]\n"
 215      "  Sign message:         \\[mh-mml-secure-message-sign]\n"
 216      "  Sign+Encrypt message: \\[mh-mml-secure-message-signencrypt]"))
 217   "Key binding cheat sheet.
 218
 219 This is an associative array which is used to show the most
 220 common commands. The key is a prefix char. The value is one or
 221 more strings which are concatenated together and displayed in the
 222 minibuffer if ? is pressed after the prefix character. The
 223 special key nil is used to display the non-prefixed commands.
 224
 225 The substitutions described in `substitute-command-keys' are
 226 performed as well.")
 227
 228 \f
 229
 230 ;;; MH-Letter Font Lock
 231
 232 (defvar mh-letter-font-lock-keywords
 233   `(,@(mh-show-font-lock-keywords-with-cite)
 234     (mh-font-lock-field-data
 235      (1 'mh-letter-header-field prepend t)))
 236   "Additional expressions to highlight in MH-Letter buffers.")
 237
 238 (defun mh-font-lock-field-data (limit)
 239   "Find header field region between point and LIMIT."
 240   (and (< (point) (mh-letter-header-end))
 241        (< (point) limit)
 242        (let ((end (min limit (mh-letter-header-end)))
 243              (point (point))
 244              data-end data-begin field)
 245          (end-of-line)
 246          (setq data-end (if (re-search-forward "^[^ \t]" end t)
 247                             (match-beginning 0)
 248                           end))
 249          (goto-char (1- data-end))
 250          (if (not (re-search-backward "\\(^[^ \t][^:]*\\):[ \t]*" nil t))
 251              (setq data-begin (point-min))
 252            (setq data-begin (match-end 0))
 253            (setq field (match-string 1)))
 254          (setq data-begin (max point data-begin))
 255          (goto-char (if (equal point data-end) (1+ data-end) data-end))
 256          (cond ((and field (mh-letter-skipped-header-field-p field))
 257                 (set-match-data nil)
 258                 nil)
 259                (t (set-match-data
 260                    (list data-begin data-end data-begin data-end))
 261                   t)))))
 262
 263 (defun mh-letter-header-end ()
 264   "Find the end of the message header.
 265 This function is to be used only for font locking. It works by
 266 searching for `mh-mail-header-separator' in the buffer."
 267   (save-excursion
 268     (goto-char (point-min))
 269     (cond ((equal mh-mail-header-separator "") (point-min))
 270           ((search-forward (format "\n%s\n" mh-mail-header-separator) nil t)
 271            (mh-line-beginning-position 0))
 272           (t (point-min)))))
 273
 274 \f
 275
 276 ;;; MH-Letter Mode
 277
 278 ;; Shush compiler.
 279 (defvar font-lock-defaults)             ; XEmacs
 280
 281 ;; Ensure new buffers won't get this mode if default-major-mode is nil.
 282 (put 'mh-letter-mode 'mode-class 'special)
 283
 284 ;;;###mh-autoload
 285 (define-derived-mode mh-letter-mode mail-mode "MH-Letter"
 286   "Mode for composing letters in MH-E\\<mh-letter-mode-map>.
 287
 288 When you have finished composing, type \\[mh-send-letter] to send
 289 the message using the MH mail handling system.
 290
 291 There are two types of tags used by MH-E when composing MIME
 292 messages: MML and MH. The option `mh-compose-insertion' controls
 293 what type of tags are inserted by MH-E commands. These tags can
 294 be converted to MIME body parts by running \\[mh-mh-to-mime] for
 295 MH-style directives or \\[mh-mml-to-mime] for MML tags.
 296
 297 Options that control this mode can be changed with
 298 \\[customize-group]; specify the \"mh-compose\" group.
 299
 300 When a message is composed, the hooks `text-mode-hook',
 301 `mail-mode-hook', and `mh-letter-mode-hook' are run (in that
 302 order).
 303
 304 \\{mh-letter-mode-map}"
 305   (mh-find-path)
 306   (make-local-variable 'mh-send-args)
 307   (make-local-variable 'mh-annotate-char)
 308   (make-local-variable 'mh-annotate-field)
 309   (make-local-variable 'mh-previous-window-config)
 310   (make-local-variable 'mh-sent-from-folder)
 311   (make-local-variable 'mh-sent-from-msg)
 312   (mh-do-in-gnu-emacs
 313     (unless mh-letter-tool-bar-map
 314       (mh-tool-bar-letter-buttons-init))
 315     (set (make-local-variable 'tool-bar-map) mh-letter-tool-bar-map))
 316   (mh-do-in-xemacs
 317     (mh-tool-bar-init :letter))
 318   ;; Set the local value of mh-mail-header-separator according to what is
 319   ;; present in the buffer...
 320   (set (make-local-variable 'mh-mail-header-separator)
 321        (save-excursion
 322          (goto-char (mh-mail-header-end))
 323          (buffer-substring-no-properties (point) (mh-line-end-position))))
 324   (make-local-variable 'mail-header-separator)
 325   (setq mail-header-separator mh-mail-header-separator) ;override sendmail.el
 326   (mh-set-help mh-letter-mode-help-messages)
 327   (setq buffer-invisibility-spec '((vanish . t) t))
 328   (set (make-local-variable 'line-move-ignore-invisible) t)
 329
 330   ;; Enable undo since a show-mode buffer might have been reused.
 331   (buffer-enable-undo)
 332   (make-local-variable 'font-lock-defaults)
 333   (cond
 334    ((or (equal mh-highlight-citation-style 'font-lock)
 335         (equal mh-highlight-citation-style 'gnus))
 336     ;; Let's use font-lock even if gnus is used in show-mode.  The reason
 337     ;; is that gnus uses static text properties which are not appropriate
 338     ;; for a buffer that will be edited.  So the choice here is either fontify
 339     ;; the citations and header...
 340     (setq font-lock-defaults '(mh-letter-font-lock-keywords t)))
 341    (t
 342     ;; ...or the header only
 343     (setq font-lock-defaults '((mh-show-font-lock-keywords) t))))
 344   (easy-menu-add mh-letter-menu)
 345   ;; Maybe we want to use the existing Mail menu from mail-mode in
 346   ;; 9.0; in the mean time, let's remove it since the redundancy will
 347   ;; only produce confusion.
 348   (define-key mh-letter-mode-map [menu-bar mail] 'undefined)
 349   (mh-do-in-xemacs (easy-menu-remove mail-menubar-menu))
 350   (setq fill-column mh-letter-fill-column)
 351   ;; If text-mode-hook turned on auto-fill, tune it for messages
 352   (when auto-fill-function
 353     (make-local-variable 'auto-fill-function)
 354     (setq auto-fill-function 'mh-auto-fill-for-letter)))
 355
 356 \f
 357
 358 ;;; MH-Letter Commands
 359
 360 ;; Alphabetical.
 361 ;; See also mh-comp.el and mh-mime.el.
 362
 363 (defun mh-check-whom ()
 364   "Verify recipients, showing expansion of any aliases.
 365
 366 This command expands aliases so you can check the actual address(es)
 367 in the alias. A new buffer named \"*MH-E Recipients*\" is created with
 368 the output of \"whom\"."
 369   (interactive)
 370   (let ((file-name buffer-file-name))
 371     (save-buffer)
 372     (message "Checking recipients...")
 373     (mh-in-show-buffer (mh-recipients-buffer)
 374       (bury-buffer (current-buffer))
 375       (erase-buffer)
 376       (mh-exec-cmd-output "whom" t file-name))
 377     (message "Checking recipients...done")))
 378
 379 (defun mh-insert-letter (folder message verbatim)
 380   "Insert a message.
 381
 382 This command prompts you for the FOLDER and MESSAGE number, which
 383 defaults to the current message in that folder. It then inserts
 384 the message, indented by `mh-ins-buf-prefix' (\"> \") unless
 385 `mh-yank-behavior' is set to one of the supercite flavors in
 386 which case supercite is used to format the message. Certain
 387 undesirable header fields (see
 388 `mh-invisible-header-fields-compiled') are removed before
 389 insertion.
 390
 391 If given a prefix argument VERBATIM, the header is left intact, the
 392 message is not indented, and \"> \" is not inserted before each line.
 393 This command leaves the mark before the letter and point after it."
 394   (interactive
 395    (let* ((folder
 396            (mh-prompt-for-folder "Message from" mh-sent-from-folder nil))
 397           (default
 398             (if (equal folder mh-sent-from-folder)
 399                 (or mh-sent-from-msg (nth 0 (mh-translate-range folder "cur")))
 400               (nth 0 (mh-translate-range folder "cur"))))
 401           (message
 402            (read-string (concat "Message number"
 403                                 (or (and default
 404                                          (format " (default %d): " default))
 405                                     ": "))
 406                         nil nil
 407                         (if (numberp default)
 408                             (int-to-string default)
 409                           default))))
 410      (list folder message current-prefix-arg)))
 411   (if (equal message "")
 412       (error "No message number given"))
 413   (save-restriction
 414     (narrow-to-region (point) (point))
 415     (let ((start (point-min)))
 416       (insert-file-contents
 417        (expand-file-name message (mh-expand-file-name folder)))
 418       (when (not verbatim)
 419         (mh-clean-msg-header start mh-invisible-header-fields-compiled nil)
 420         (goto-char (point-max))         ;Needed for sc-cite-original
 421         (push-mark)                     ;Needed for sc-cite-original
 422         (goto-char (point-min))         ;Needed for sc-cite-original
 423         (mh-insert-prefix-string mh-ins-buf-prefix)))))
 424
 425 ;;;###mh-autoload
 426 (defun mh-insert-signature (&optional file)
 427   "Insert signature in message.
 428
 429 This command inserts your signature at the current cursor location.
 430
 431 By default, the text of your signature is taken from the file
 432 \"~/.signature\". You can read from other sources by changing the
 433 option `mh-signature-file-name'.
 434
 435 A signature separator (\"-- \") will be added if the signature block
 436 does not contain one and `mh-signature-separator-flag' is on.
 437
 438 The hook `mh-insert-signature-hook' is run after the signature is
 439 inserted. Hook functions may access the actual name of the file or the
 440 function used to insert the signature with `mh-signature-file-name'.
 441
 442 The signature can also be inserted using Identities (see
 443 `mh-identity-list').
 444
 445 In a program, you can pass in a signature FILE."
 446   (interactive)
 447   (save-excursion
 448     (insert "\n")
 449     (let ((mh-signature-file-name (or file mh-signature-file-name))
 450           (mh-mh-p (mh-mh-directive-present-p))
 451           (mh-mml-p (mh-mml-tag-present-p)))
 452       (save-restriction
 453         (narrow-to-region (point) (point))
 454         (cond
 455          ((mh-file-is-vcard-p mh-signature-file-name)
 456           (if (equal mh-compose-insertion 'mml)
 457               (insert "<#part type=\"text/x-vcard\" filename=\""
 458                       mh-signature-file-name
 459                       "\" disposition=inline description=VCard>\n<#/part>")
 460             (insert "#text/x-vcard; name=\""
 461                     (file-name-nondirectory mh-signature-file-name)
 462                     "\" [VCard] " (expand-file-name mh-signature-file-name))))
 463          (t
 464           (cond
 465            (mh-mh-p
 466             (insert "#\n" "Content-Description: Signature\n"))
 467            (mh-mml-p
 468             (mml-insert-tag 'part 'type "text/plain" 'disposition "inline"
 469                             'description "Signature")))
 470           (cond ((null mh-signature-file-name))
 471                 ((and (stringp mh-signature-file-name)
 472                       (file-readable-p mh-signature-file-name))
 473                  (insert-file-contents mh-signature-file-name))
 474                 ((functionp mh-signature-file-name)
 475                  (funcall mh-signature-file-name)))))
 476         (save-restriction
 477           (widen)
 478           (run-hooks 'mh-insert-signature-hook))
 479         (goto-char (point-min))
 480         (when (and (not (mh-file-is-vcard-p mh-signature-file-name))
 481                    mh-signature-separator-flag
 482                    (> (point-max) (point-min))
 483                    (not (mh-signature-separator-p)))
 484           (cond (mh-mh-p
 485                  (forward-line 2))
 486                 (mh-mml-p
 487                  (forward-line 1)))
 488           (insert mh-signature-separator))
 489         (if (not (> (point-max) (point-min)))
 490             (message "No signature found")))))
 491   (force-mode-line-update))
 492
 493 (defun mh-letter-complete (arg)
 494   "Perform completion on header field or word preceding point.
 495
 496 If the field contains addresses (for example, \"To:\" or \"Cc:\")
 497 or folders (for example, \"Fcc:\") then this command will provide
 498 alias completion. In the body of the message, this command runs
 499 `mh-letter-complete-function' instead, which is set to
 500 `ispell-complete-word' by default. This command takes a prefix
 501 argument ARG that is passed to the
 502 `mh-letter-complete-function'."
 503   (interactive "P")
 504   (let ((func nil))
 505     (cond ((not (mh-in-header-p))
 506            (funcall mh-letter-complete-function arg))
 507           ((setq func (cdr (assoc (mh-letter-header-field-at-point)
 508                                   mh-letter-complete-function-alist)))
 509            (funcall func))
 510           (t (funcall mh-letter-complete-function arg)))))
 511
 512 (defun mh-letter-complete-or-space (arg)
 513   "Perform completion or insert space.
 514
 515 Turn on the option `mh-compose-space-does-completion-flag' to use
 516 this command to perform completion in the header. Otherwise, a
 517 space is inserted; use a prefix argument ARG to specify more than
 518 one space."
 519   (interactive "p")
 520   (let ((func nil)
 521         (end-of-prev (save-excursion
 522                        (goto-char (mh-beginning-of-word))
 523                        (mh-beginning-of-word -1))))
 524     (cond ((not mh-compose-space-does-completion-flag)
 525            (self-insert-command arg))
 526           ((not (mh-in-header-p)) (self-insert-command arg))
 527           ((> (point) end-of-prev) (self-insert-command arg))
 528           ((setq func (cdr (assoc (mh-letter-header-field-at-point)
 529                                   mh-letter-complete-function-alist)))
 530            (funcall func))
 531           (t (self-insert-command arg)))))
 532
 533 (defun mh-letter-confirm-address ()
 534   "Flash alias expansion.
 535
 536 Addresses are separated by a comma\; when you press the comma,
 537 this command flashes the alias expansion in the minibuffer if
 538 `mh-alias-flash-on-comma' is turned on."
 539   (interactive)
 540   (cond ((not (mh-in-header-p)) (self-insert-command 1))
 541         ((eq (cdr (assoc (mh-letter-header-field-at-point)
 542                          mh-letter-complete-function-alist))
 543              'mh-alias-letter-expand-alias)
 544          (mh-alias-reload-maybe)
 545          (mh-alias-minibuffer-confirm-address))
 546         (t (self-insert-command 1))))
 547
 548 (defun mh-letter-next-header-field-or-indent (arg)
 549   "Cycle to next field.
 550
 551 Within the header of the message, this command moves between
 552 fields that are highlighted with the face
 553 `mh-letter-header-field', skipping those fields listed in
 554 `mh-compose-skipped-header-fields'. After the last field, this
 555 command then moves point to the message body before cycling back
 556 to the first field. If point is already past the first line of
 557 the message body, then this command indents by calling
 558 `indent-relative' with the given prefix argument ARG."
 559   (interactive "P")
 560   (let ((header-end (save-excursion
 561                       (goto-char (mh-mail-header-end))
 562                       (forward-line)
 563                       (point))))
 564     (if (> (point) header-end)
 565         (indent-relative arg)
 566       (mh-letter-next-header-field))))
 567
 568 (defun mh-letter-previous-header-field ()
 569   "Cycle to the previous header field.
 570
 571 This command moves backwards between the fields and cycles to the
 572 body of the message after the first field. Unlike the command
 573 \\[mh-letter-next-header-field-or-indent], it will always take
 574 point to the last field from anywhere in the body."
 575   (interactive)
 576   (let ((header-end (mh-mail-header-end)))
 577     (if (>= (point) header-end)
 578         (goto-char header-end)
 579       (mh-header-field-beginning))
 580     (cond ((re-search-backward mh-letter-header-field-regexp nil t)
 581            (if (mh-letter-skipped-header-field-p (match-string 1))
 582                (mh-letter-previous-header-field)
 583            (goto-char (match-end 0))
 584            (mh-letter-skip-leading-whitespace-in-header-field)))
 585           (t (goto-char header-end)
 586              (forward-line)))))
 587
 588 (defun mh-open-line ()
 589   "Insert a newline and leave point before it.
 590
 591 This command is similar to the command \\[open-line] in that it
 592 inserts a newline after point. It differs in that it also inserts
 593 the right number of quoting characters and spaces so that the
 594 next line begins in the same column as it was. This is useful
 595 when breaking up paragraphs in replies."
 596   (interactive)
 597   (let ((column (current-column))
 598         (prefix (mh-current-fill-prefix)))
 599     (if (> (length prefix) column)
 600         (message "Sorry, point seems to be within the line prefix")
 601       (newline 2)
 602       (insert prefix)
 603       (while (> column (current-column))
 604         (insert " "))
 605       (forward-line -1))))
 606
 607 (defun mh-to-fcc (&optional folder)
 608   "Move to \"Fcc:\" header field.
 609
 610 This command will prompt you for the FOLDER name in which to file
 611 a copy of the draft."
 612   (interactive (list (mh-prompt-for-folder
 613                       "Fcc"
 614                       (or (and mh-default-folder-for-message-function
 615                                (save-excursion
 616                                  (goto-char (point-min))
 617                                  (funcall
 618                                   mh-default-folder-for-message-function)))
 619                           "")
 620                       t)))
 621   (let ((last-input-char ?\C-f))
 622     (expand-abbrev)
 623     (save-excursion
 624       (mh-to-field)
 625       (insert (if (mh-folder-name-p folder)
 626                   (substring folder 1)
 627                 folder)))))
 628
 629 (defvar mh-to-field-choices '(("a" . "Mail-Reply-To:")
 630                               ("b" . "Bcc:")
 631                               ("c" . "Cc:")
 632                               ("d" . "Dcc:")
 633                               ("f" . "Fcc:")
 634                               ("l" . "Mail-Followup-To:")
 635                               ("m" . "From:")
 636                               ("r" . "Reply-To:")
 637                               ("s" . "Subject:")
 638                               ("t" . "To:"))
 639   "Alist of (final-character . field-name) choices for `mh-to-field'.")
 640
 641 (defun mh-to-field ()
 642   "Move to specified header field.
 643
 644 The field is indicated by the previous keystroke (the last
 645 keystroke of the command) according to the list in the variable
 646 `mh-to-field-choices'.
 647 Create the field if it does not exist.
 648 Set the mark to point before moving."
 649   (interactive)
 650   (expand-abbrev)
 651   (let ((target (cdr (or (assoc (char-to-string (logior last-input-char ?`))
 652                                 mh-to-field-choices)
 653                          ;; also look for a char for version 4 compat
 654                          (assoc (logior last-input-char ?`)
 655                                 mh-to-field-choices))))
 656         (case-fold-search t))
 657     (push-mark)
 658     (cond ((mh-position-on-field target)
 659            (let ((eol (point)))
 660              (skip-chars-backward " \t")
 661              (delete-region (point) eol))
 662            (if (and (not (eq (logior last-input-char ?`) ?s))
 663                     (save-excursion
 664                       (backward-char 1)
 665                       (not (looking-at "[:,]"))))
 666                (insert ", ")
 667              (insert " ")))
 668           (t
 669            (if (mh-position-on-field "To:")
 670                (forward-line 1))
 671            (insert (format "%s \n" target))
 672            (backward-char 1)))))
 673
 674 ;;;###mh-autoload
 675 (defun mh-yank-cur-msg ()
 676   "Insert the current message into the draft buffer.
 677
 678 It is often useful to insert a snippet of text from a letter that
 679 someone mailed to provide some context for your reply. This
 680 command does this by adding an attribution, yanking a portion of
 681 text from the message to which you're replying, and inserting
 682 `mh-ins-buf-prefix' (`> ') before each line.
 683
 684 The attribution consists of the sender's name and email address
 685 followed by the content of the option
 686 `mh-extract-from-attribution-verb'.
 687
 688 You can also turn on the option
 689 `mh-delete-yanked-msg-window-flag' to delete the window
 690 containing the original message after yanking it to make more
 691 room on your screen for your reply.
 692
 693 You can control how the message to which you are replying is
 694 yanked into your reply using `mh-yank-behavior'.
 695
 696 If this isn't enough, you can gain full control over the
 697 appearance of the included text by setting `mail-citation-hook'
 698 to a function that modifies it. For example, if you set this hook
 699 to `trivial-cite' (which is NOT part of Emacs), set
 700 `mh-yank-behavior' to \"Body and Header\" (see URL
 701 `http://shasta.cs.uiuc.edu/~lrclause/tc.html').
 702
 703 Note that if `mail-citation-hook' is set, `mh-ins-buf-prefix' is
 704 not inserted. If the option `mh-yank-behavior' is set to one of
 705 the supercite flavors, the hook `mail-citation-hook' is ignored
 706 and `mh-ins-buf-prefix' is not inserted."
 707   (interactive)
 708   (if (and mh-sent-from-folder
 709            (save-excursion (set-buffer mh-sent-from-folder) mh-show-buffer)
 710            (save-excursion (set-buffer mh-sent-from-folder)
 711                            (get-buffer mh-show-buffer))
 712            mh-sent-from-msg)
 713       (let ((to-point (point))
 714             (to-buffer (current-buffer)))
 715         (set-buffer mh-sent-from-folder)
 716         (if mh-delete-yanked-msg-window-flag
 717             (delete-windows-on mh-show-buffer))
 718         (set-buffer mh-show-buffer)     ; Find displayed message
 719         (let* ((from-attr (mh-extract-from-attribution))
 720                (yank-region (mh-mark-active-p nil))
 721                (mh-ins-str
 722                 (cond ((and yank-region
 723                             (or (eq 'supercite mh-yank-behavior)
 724                                 (eq 'autosupercite mh-yank-behavior)
 725                                 (eq t mh-yank-behavior)))
 726                        ;; supercite needs the full header
 727                        (concat
 728                         (buffer-substring (point-min) (mh-mail-header-end))
 729                         "\n"
 730                         (buffer-substring (region-beginning) (region-end))))
 731                       (yank-region
 732                        (buffer-substring (region-beginning) (region-end)))
 733                       ((or (eq 'body mh-yank-behavior)
 734                            (eq 'attribution mh-yank-behavior)
 735                            (eq 'autoattrib mh-yank-behavior))
 736                        (buffer-substring
 737                         (save-excursion
 738                           (goto-char (point-min))
 739                           (mh-goto-header-end 1)
 740                           (point))
 741                         (point-max)))
 742                       ((or (eq 'supercite mh-yank-behavior)
 743                            (eq 'autosupercite mh-yank-behavior)
 744                            (eq t mh-yank-behavior))
 745                        (buffer-substring (point-min) (point-max)))
 746                       (t
 747                        (buffer-substring (point) (point-max))))))
 748           (set-buffer to-buffer)
 749           (save-restriction
 750             (narrow-to-region to-point to-point)
 751             (insert (mh-filter-out-non-text mh-ins-str))
 752             (goto-char (point-max))     ;Needed for sc-cite-original
 753             (push-mark)                 ;Needed for sc-cite-original
 754             (goto-char (point-min))     ;Needed for sc-cite-original
 755             (mh-insert-prefix-string mh-ins-buf-prefix)
 756             (when (or (eq 'attribution mh-yank-behavior)
 757                       (eq 'autoattrib mh-yank-behavior))
 758               (insert from-attr)
 759               (mh-identity-insert-attribution-verb nil)
 760               (insert "\n\n"))
 761             ;; If the user has selected a region, he has already "edited" the
 762             ;; text, so leave the cursor at the end of the yanked text. In
 763             ;; either case, leave a mark at the opposite end of the included
 764             ;; text to make it easy to jump or delete to the other end of the
 765             ;; text.
 766             (push-mark)
 767             (goto-char (point-max))
 768             (if (null yank-region)
 769                 (mh-exchange-point-and-mark-preserving-active-mark)))))
 770     (error "There is no current message")))
 771
 772 \f
 773
 774 ;;; Support Routines
 775
 776 (defun mh-auto-fill-for-letter ()
 777   "Perform auto-fill for message.
 778 Header is treated specially by inserting a tab before continuation
 779 lines."
 780   (if (mh-in-header-p)
 781       (let ((fill-prefix "\t"))
 782         (do-auto-fill))
 783     (do-auto-fill)))
 784
 785 (defun mh-filter-out-non-text (string)
 786   "Return STRING but without adornments such as MIME buttons and smileys."
 787   (with-temp-buffer
 788     ;; Insert the string to filter
 789     (insert string)
 790     (goto-char (point-min))
 791
 792     ;; Remove the MIME buttons
 793     (let ((can-move-forward t)
 794           (in-button nil))
 795       (while can-move-forward
 796         (cond ((and (not (get-text-property (point) 'mh-data))
 797                     in-button)
 798                (delete-region (1- (point)) (point))
 799                (setq in-button nil))
 800               ((get-text-property (point) 'mh-data)
 801                (delete-region (point)
 802                               (save-excursion (forward-line) (point)))
 803                (setq in-button t))
 804               (t (setq can-move-forward (= (forward-line) 0))))))
 805
 806     ;; Return the contents without properties... This gets rid of emphasis
 807     ;; and smileys
 808     (buffer-substring-no-properties (point-min) (point-max))))
 809
 810 (defun mh-current-fill-prefix ()
 811   "Return the `fill-prefix' on the current line as a string."
 812   (save-excursion
 813     (beginning-of-line)
 814     ;; This assumes that the major-mode sets up adaptive-fill-regexp
 815     ;; correctly such as mh-letter-mode or sendmail.el's mail-mode.  But
 816     ;; perhaps I should use the variable and simply inserts its value here,
 817     ;; and set it locally in a let scope.  --psg
 818     (if (re-search-forward adaptive-fill-regexp nil t)
 819         (match-string 0)
 820       "")))
 821
 822 ;;;###mh-autoload
 823 (defun mh-letter-next-header-field ()
 824   "Cycle to the next header field.
 825 If we are at the last header field go to the start of the message
 826 body."
 827   (let ((header-end (mh-mail-header-end)))
 828     (cond ((>= (point) header-end) (goto-char (point-min)))
 829           ((< (point) (progn
 830                         (beginning-of-line)
 831                         (re-search-forward mh-letter-header-field-regexp
 832                                            (mh-line-end-position) t)
 833                         (point)))
 834            (beginning-of-line))
 835           (t (end-of-line)))
 836     (cond ((re-search-forward mh-letter-header-field-regexp header-end t)
 837            (if (mh-letter-skipped-header-field-p (match-string 1))
 838                (mh-letter-next-header-field)
 839              (mh-letter-skip-leading-whitespace-in-header-field)))
 840           (t (goto-char header-end)
 841              (forward-line)))))
 842
 843 ;;;###mh-autoload
 844 (defun mh-position-on-field (field &optional ignored)
 845   "Move to the end of the FIELD in the header.
 846 Move to end of entire header if FIELD not found.
 847 Returns non-nil if FIELD was found.
 848 The optional second arg is for pre-version 4 compatibility and is
 849 IGNORED."
 850   (cond ((mh-goto-header-field field)
 851          (mh-header-field-end)
 852          t)
 853         ((mh-goto-header-end 0)
 854          nil)))
 855
 856 (defun mh-letter-header-field-at-point ()
 857   "Return the header field name at point.
 858 A symbol is returned whose name is the string obtained by
 859 downcasing the field name."
 860   (save-excursion
 861     (end-of-line)
 862     (and (re-search-backward mh-letter-header-field-regexp nil t)
 863          (intern (downcase (match-string 1))))))
 864
 865 (defun mh-folder-expand-at-point ()
 866   "Do folder name completion in Fcc header field."
 867   (let* ((end (point))
 868          (beg (mh-beginning-of-word))
 869          (folder (buffer-substring-no-properties beg end))
 870          (leading-plus (and (> (length folder) 0) (equal (aref folder 0) ?+)))
 871          (choices (mapcar (lambda (x) (list x))
 872                           (mh-folder-completion-function folder nil t))))
 873     (unless leading-plus
 874       (setq folder (concat "+" folder)))
 875     (mh-complete-word folder choices beg end)))
 876
 877 ;;;###mh-autoload
 878 (defun mh-complete-word (word choices begin end)
 879   "Complete WORD at from CHOICES.
 880 Any match found replaces the text from BEGIN to END."
 881   (let ((completion (try-completion word choices))
 882         (completions-buffer "*Completions*"))
 883     (cond ((eq completion t)
 884            (ignore-errors
 885              (kill-buffer completions-buffer))
 886            (message "Completed: %s" word))
 887           ((null completion)
 888            (ignore-errors
 889              (kill-buffer completions-buffer))
 890            (message "No completion for %s" word))
 891           ((stringp completion)
 892            (if (equal word completion)
 893                (with-output-to-temp-buffer completions-buffer
 894                  (mh-display-completion-list (all-completions word choices)
 895                                              word))
 896              (ignore-errors
 897                (kill-buffer completions-buffer))
 898              (delete-region begin end)
 899              (insert completion))))))
 900
 901 (defun mh-file-is-vcard-p (file)
 902   "Return t if FILE is a .vcf vcard."
 903   (let ((case-fold-search t))
 904     (and (stringp file)
 905          (file-exists-p file)
 906          (or (and (not (mh-have-file-command))
 907                   (not (null (string-match "\.vcf$" file))))
 908              (string-equal "text/x-vcard" (mh-file-mime-type file))))))
 909
 910 ;;;###mh-autoload
 911 (defun mh-letter-toggle-header-field-display-button (event)
 912   "Toggle header field display at location of EVENT.
 913 This function does the same thing as
 914 `mh-letter-toggle-header-field-display' except that it is
 915 callable from a mouse button."
 916   (interactive "e")
 917   (mh-do-at-event-location event
 918     (mh-letter-toggle-header-field-display nil)))
 919
 920 (defun mh-extract-from-attribution ()
 921   "Extract phrase or comment from From header field."
 922   (save-excursion
 923     (if (not (mh-goto-header-field "From: "))
 924         nil
 925       (skip-chars-forward " ")
 926       (cond
 927        ((looking-at "\"\\([^\"\n]+\\)\" \\(<.+>\\)")
 928         (format "%s %s " (match-string 1)(match-string 2)))
 929        ((looking-at "\\([^<\n]+<.+>\\)$")
 930         (format "%s " (match-string 1)))
 931        ((looking-at "\\([^ ]+@[^ ]+\\) +(\\(.+\\))$")
 932         (format "%s <%s> " (match-string 2)(match-string 1)))
 933        ((looking-at " *\\(.+\\)$")
 934         (format "%s " (match-string 1)))))))
 935
 936 (defun mh-insert-prefix-string (mh-ins-string)
 937   "Insert prefix string before each line in buffer.
 938 The inserted letter is cited using `sc-cite-original' if
 939 `mh-yank-behavior' is one of 'supercite or 'autosupercite.
 940 Otherwise, simply insert MH-INS-STRING before each line."
 941   (goto-char (point-min))
 942   (cond ((or (eq mh-yank-behavior 'supercite)
 943              (eq mh-yank-behavior 'autosupercite))
 944          (sc-cite-original))
 945         (mail-citation-hook
 946          (run-hooks 'mail-citation-hook))
 947         (mh-yank-hooks                  ;old hook name
 948          (run-hooks 'mh-yank-hooks))
 949         (t
 950          (or (bolp) (forward-line 1))
 951          (while (< (point) (point-max))
 952            (insert mh-ins-string)
 953            (forward-line 1))
 954          (goto-char (point-min)))))     ;leave point like sc-cite-original
 955
 956 (provide 'mh-letter)
 957
 958 ;; Local Variables:
 959 ;; indent-tabs-mode: nil
 960 ;; sentence-end-double-space: nil
 961 ;; End:
 962
 963 ;; arch-tag: 0548632c-aadb-4e3b-bb80-bbd62ff90bf3
 964 ;;; mh-letter.el ends here