lisp/mh-e/mh-letter.el

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