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
 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 ;; TODO Now that completion-at-point performs the task of
 506 ;; mh-letter-complete, perhaps mh-letter-complete along with
 507 ;; mh-complete-word should be rewritten as a more general function for
 508 ;; XEmacs, renamed to mh-completion-at-point, and moved to
 509 ;; mh-compat.el.
 510 (defun-mh mh-letter-complete completion-at-point ()
 511   "Perform completion on header field or word preceding point.
 512
 513 If the field contains addresses (for example, \"To:\" or \"Cc:\")
 514 or folders (for example, \"Fcc:\") then this command will provide
 515 alias completion. In the body of the message, this command runs
 516 `mh-letter-complete-function' instead, which is set to
 517 `ispell-complete-word' by default."
 518       (interactive)
 519       (let ((data (mh-letter-completion-at-point)))
 520         (cond
 521          ((functionp data) (funcall data))
 522          ((consp data)
 523           (let ((start (nth 0 data))
 524                 (end (nth 1 data))
 525                 (table (nth 2 data)))
 526             (mh-complete-word (buffer-substring-no-properties start end)
 527                               table start end))))))
 528
 529 (defun mh-letter-complete-or-space (arg)
 530   "Perform completion or insert space.
 531
 532 Turn on the option `mh-compose-space-does-completion-flag' to use
 533 this command to perform completion in the header. Otherwise, a
 534 space is inserted; use a prefix argument ARG to specify more than
 535 one space."
 536   (interactive "p")
 537   (let ((end-of-prev (save-excursion
 538                        (goto-char (mh-beginning-of-word))
 539                        (mh-beginning-of-word -1))))
 540     (cond ((not mh-compose-space-does-completion-flag)
 541            (self-insert-command arg))
 542           ;; FIXME: This > test is redundant now that all the completion
 543           ;; functions do it anyway.
 544           ((> (point) end-of-prev) (self-insert-command arg))
 545           ((let ((mh-letter-complete-function nil))
 546              (mh-letter-completion-at-point))
 547            (mh-letter-complete))
 548           (t (self-insert-command arg)))))
 549
 550 (defun mh-letter-confirm-address ()
 551   "Flash alias expansion.
 552
 553 Addresses are separated by a comma\; when you press the comma,
 554 this command flashes the alias expansion in the minibuffer if
 555 `mh-alias-flash-on-comma' is turned on."
 556   (interactive)
 557   (cond ((not (mh-in-header-p)) (self-insert-command 1))
 558         ((eq (cdr (assoc (mh-letter-header-field-at-point)
 559                          mh-letter-complete-function-alist))
 560              'mh-alias-letter-expand-alias)
 561          (mh-alias-reload-maybe)
 562          (mh-alias-minibuffer-confirm-address))
 563         (t (self-insert-command 1))))
 564
 565 (defun mh-letter-next-header-field-or-indent (arg)
 566   "Cycle to next field.
 567
 568 Within the header of the message, this command moves between
 569 fields that are highlighted with the face
 570 `mh-letter-header-field', skipping those fields listed in
 571 `mh-compose-skipped-header-fields'. After the last field, this
 572 command then moves point to the message body before cycling back
 573 to the first field. If point is already past the first line of
 574 the message body, then this command indents by calling
 575 `indent-relative' with the given prefix argument ARG."
 576   (interactive "P")
 577   (let ((header-end (save-excursion
 578                       (goto-char (mh-mail-header-end))
 579                       (forward-line)
 580                       (point))))
 581     (if (> (point) header-end)
 582         (indent-relative arg)
 583       (mh-letter-next-header-field))))
 584
 585 (defun mh-letter-previous-header-field ()
 586   "Cycle to the previous header field.
 587
 588 This command moves backwards between the fields and cycles to the
 589 body of the message after the first field. Unlike the command
 590 \\[mh-letter-next-header-field-or-indent], it will always take
 591 point to the last field from anywhere in the body."
 592   (interactive)
 593   (let ((header-end (mh-mail-header-end)))
 594     (if (>= (point) header-end)
 595         (goto-char header-end)
 596       (mh-header-field-beginning))
 597     (cond ((re-search-backward mh-letter-header-field-regexp nil t)
 598            (if (mh-letter-skipped-header-field-p (match-string 1))
 599                (mh-letter-previous-header-field)
 600            (goto-char (match-end 0))
 601            (mh-letter-skip-leading-whitespace-in-header-field)))
 602           (t (goto-char header-end)
 603              (forward-line)))))
 604
 605 (defun mh-open-line ()
 606   "Insert a newline and leave point before it.
 607
 608 This command is similar to the command \\[open-line] in that it
 609 inserts a newline after point. It differs in that it also inserts
 610 the right number of quoting characters and spaces so that the
 611 next line begins in the same column as it was. This is useful
 612 when breaking up paragraphs in replies."
 613   (interactive)
 614   (let ((column (current-column))
 615         (prefix (mh-current-fill-prefix)))
 616     (if (> (length prefix) column)
 617         (message "Sorry, point seems to be within the line prefix")
 618       (newline 2)
 619       (insert prefix)
 620       (while (> column (current-column))
 621         (insert " "))
 622       (forward-line -1))))
 623
 624 (defun mh-to-fcc (&optional folder)
 625   "Move to \"Fcc:\" header field.
 626
 627 This command will prompt you for the FOLDER name in which to file
 628 a copy of the draft."
 629   (interactive (list (mh-prompt-for-folder
 630                       "Fcc"
 631                       (or (and mh-default-folder-for-message-function
 632                                (save-excursion
 633                                  (goto-char (point-min))
 634                                  (funcall
 635                                   mh-default-folder-for-message-function)))
 636                           "")
 637                       t)))
 638   (let ((last-input-event ?\C-f))
 639     (expand-abbrev)
 640     (save-excursion
 641       (mh-to-field)
 642       (insert (if (mh-folder-name-p folder)
 643                   (substring folder 1)
 644                 folder)))))
 645
 646 (defvar mh-to-field-choices '(("a" . "Mail-Reply-To:")
 647                               ("b" . "Bcc:")
 648                               ("c" . "Cc:")
 649                               ("d" . "Dcc:")
 650                               ("f" . "Fcc:")
 651                               ("l" . "Mail-Followup-To:")
 652                               ("m" . "From:")
 653                               ("r" . "Reply-To:")
 654                               ("s" . "Subject:")
 655                               ("t" . "To:"))
 656   "Alist of (final-character . field-name) choices for `mh-to-field'.")
 657
 658 (defun mh-to-field ()
 659   "Move to specified header field.
 660
 661 The field is indicated by the previous keystroke (the last
 662 keystroke of the command) according to the list in the variable
 663 `mh-to-field-choices'.
 664 Create the field if it does not exist.
 665 Set the mark to point before moving."
 666   (interactive)
 667   (expand-abbrev)
 668   (let ((target (cdr (or (assoc (char-to-string (logior last-input-event ?`))
 669                                 mh-to-field-choices)
 670                          ;; also look for a char for version 4 compat
 671                          (assoc (logior last-input-event ?`)
 672                                 mh-to-field-choices))))
 673         (case-fold-search t))
 674     (push-mark)
 675     (cond ((mh-position-on-field target)
 676            (let ((eol (point)))
 677              (skip-chars-backward " \t")
 678              (delete-region (point) eol))
 679            (if (and (not (eq (logior last-input-event ?`) ?s))
 680                     (save-excursion
 681                       (backward-char 1)
 682                       (not (looking-at "[:,]"))))
 683                (insert ", ")
 684              (insert " ")))
 685           (t
 686            (if (mh-position-on-field "To:")
 687                (forward-line 1))
 688            (insert (format "%s \n" target))
 689            (backward-char 1)))))
 690
 691 ;;;###mh-autoload
 692 (defun mh-yank-cur-msg ()
 693   "Insert the current message into the draft buffer.
 694
 695 It is often useful to insert a snippet of text from a letter that
 696 someone mailed to provide some context for your reply. This
 697 command does this by adding an attribution, yanking a portion of
 698 text from the message to which you're replying, and inserting
 699 `mh-ins-buf-prefix' (`> ') before each line.
 700
 701 The attribution consists of the sender's name and email address
 702 followed by the content of the option
 703 `mh-extract-from-attribution-verb'.
 704
 705 You can also turn on the option
 706 `mh-delete-yanked-msg-window-flag' to delete the window
 707 containing the original message after yanking it to make more
 708 room on your screen for your reply.
 709
 710 You can control how the message to which you are replying is
 711 yanked into your reply using `mh-yank-behavior'.
 712
 713 If this isn't enough, you can gain full control over the
 714 appearance of the included text by setting `mail-citation-hook'
 715 to a function that modifies it. For example, if you set this hook
 716 to `trivial-cite' (which is NOT part of Emacs), set
 717 `mh-yank-behavior' to \"Body and Header\" (see URL
 718 `http://shasta.cs.uiuc.edu/~lrclause/tc.html').
 719
 720 Note that if `mail-citation-hook' is set, `mh-ins-buf-prefix' is
 721 not inserted. If the option `mh-yank-behavior' is set to one of
 722 the supercite flavors, the hook `mail-citation-hook' is ignored
 723 and `mh-ins-buf-prefix' is not inserted."
 724   (interactive)
 725   (if (and mh-sent-from-folder
 726            (with-current-buffer mh-sent-from-folder mh-show-buffer)
 727            (with-current-buffer mh-sent-from-folder
 728              (get-buffer mh-show-buffer))
 729            mh-sent-from-msg)
 730       (let ((to-point (point))
 731             (to-buffer (current-buffer)))
 732         (set-buffer mh-sent-from-folder)
 733         (if mh-delete-yanked-msg-window-flag
 734             (delete-windows-on mh-show-buffer))
 735         (set-buffer mh-show-buffer)     ; Find displayed message
 736         (let* ((from-attr (mh-extract-from-attribution))
 737                (yank-region (mh-mark-active-p nil))
 738                (mh-ins-str
 739                 (cond ((and yank-region
 740                             (or (eq 'supercite mh-yank-behavior)
 741                                 (eq 'autosupercite mh-yank-behavior)
 742                                 (eq t mh-yank-behavior)))
 743                        ;; supercite needs the full header
 744                        (concat
 745                         (buffer-substring (point-min) (mh-mail-header-end))
 746                         "\n"
 747                         (buffer-substring (region-beginning) (region-end))))
 748                       (yank-region
 749                        (buffer-substring (region-beginning) (region-end)))
 750                       ((or (eq 'body mh-yank-behavior)
 751                            (eq 'attribution mh-yank-behavior)
 752                            (eq 'autoattrib mh-yank-behavior))
 753                        (buffer-substring
 754                         (save-excursion
 755                           (goto-char (point-min))
 756                           (mh-goto-header-end 1)
 757                           (point))
 758                         (point-max)))
 759                       ((or (eq 'supercite mh-yank-behavior)
 760                            (eq 'autosupercite mh-yank-behavior)
 761                            (eq t mh-yank-behavior))
 762                        (buffer-substring (point-min) (point-max)))
 763                       (t
 764                        (buffer-substring (point) (point-max))))))
 765           (set-buffer to-buffer)
 766           (save-restriction
 767             (narrow-to-region to-point to-point)
 768             (insert (mh-filter-out-non-text mh-ins-str))
 769             (goto-char (point-max))     ;Needed for sc-cite-original
 770             (push-mark)                 ;Needed for sc-cite-original
 771             (goto-char (point-min))     ;Needed for sc-cite-original
 772             (mh-insert-prefix-string mh-ins-buf-prefix)
 773             (when (or (eq 'attribution mh-yank-behavior)
 774                       (eq 'autoattrib mh-yank-behavior))
 775               (insert from-attr)
 776               (mh-identity-insert-attribution-verb nil)
 777               (insert "\n\n"))
 778             ;; If the user has selected a region, he has already "edited" the
 779             ;; text, so leave the cursor at the end of the yanked text. In
 780             ;; either case, leave a mark at the opposite end of the included
 781             ;; text to make it easy to jump or delete to the other end of the
 782             ;; text.
 783             (push-mark)
 784             (goto-char (point-max))
 785             (if (null yank-region)
 786                 (mh-exchange-point-and-mark-preserving-active-mark)))))
 787     (error "There is no current message")))
 788
 789 \f
 790
 791 ;;; Support Routines
 792
 793 (defun mh-auto-fill-for-letter ()
 794   "Perform auto-fill for message.
 795 Header is treated specially by inserting a tab before continuation
 796 lines."
 797   (if (mh-in-header-p)
 798       (let ((fill-prefix "\t"))
 799         (do-auto-fill))
 800     (do-auto-fill)))
 801
 802 (defun mh-filter-out-non-text (string)
 803   "Return STRING but without adornments such as MIME buttons and smileys."
 804   (with-temp-buffer
 805     ;; Insert the string to filter
 806     (insert string)
 807     (goto-char (point-min))
 808
 809     ;; Remove the MIME buttons
 810     (let ((can-move-forward t)
 811           (in-button nil))
 812       (while can-move-forward
 813         (cond ((and (not (get-text-property (point) 'mh-data))
 814                     in-button)
 815                (delete-region (1- (point)) (point))
 816                (setq in-button nil))
 817               ((get-text-property (point) 'mh-data)
 818                (delete-region (point)
 819                               (save-excursion (forward-line) (point)))
 820                (setq in-button t))
 821               (t (setq can-move-forward (= (forward-line) 0))))))
 822
 823     ;; Return the contents without properties... This gets rid of emphasis
 824     ;; and smileys
 825     (buffer-substring-no-properties (point-min) (point-max))))
 826
 827 (defun mh-current-fill-prefix ()
 828   "Return the `fill-prefix' on the current line as a string."
 829   (save-excursion
 830     (beginning-of-line)
 831     ;; This assumes that the major-mode sets up adaptive-fill-regexp
 832     ;; correctly such as mh-letter-mode or sendmail.el's mail-mode.  But
 833     ;; perhaps I should use the variable and simply inserts its value here,
 834     ;; and set it locally in a let scope.  --psg
 835     (if (re-search-forward adaptive-fill-regexp nil t)
 836         (match-string 0)
 837       "")))
 838
 839 ;;;###mh-autoload
 840 (defun mh-letter-next-header-field ()
 841   "Cycle to the next header field.
 842 If we are at the last header field go to the start of the message
 843 body."
 844   (let ((header-end (mh-mail-header-end)))
 845     (cond ((>= (point) header-end) (goto-char (point-min)))
 846           ((< (point) (progn
 847                         (beginning-of-line)
 848                         (re-search-forward mh-letter-header-field-regexp
 849                                            (mh-line-end-position) t)
 850                         (point)))
 851            (beginning-of-line))
 852           (t (end-of-line)))
 853     (cond ((re-search-forward mh-letter-header-field-regexp header-end t)
 854            (if (mh-letter-skipped-header-field-p (match-string 1))
 855                (mh-letter-next-header-field)
 856              (mh-letter-skip-leading-whitespace-in-header-field)))
 857           (t (goto-char header-end)
 858              (forward-line)))))
 859
 860 ;;;###mh-autoload
 861 (defun mh-position-on-field (field &optional ignored)
 862   "Move to the end of the FIELD in the header.
 863 Move to end of entire header if FIELD not found.
 864 Returns non-nil if FIELD was found.
 865 The optional second arg is for pre-version 4 compatibility and is
 866 IGNORED."
 867   (cond ((mh-goto-header-field field)
 868          (mh-header-field-end)
 869          t)
 870         ((mh-goto-header-end 0)
 871          nil)))
 872
 873 (defun mh-letter-header-field-at-point ()
 874   "Return the header field name at point.
 875 A symbol is returned whose name is the string obtained by
 876 downcasing the field name."
 877   (save-excursion
 878     (end-of-line)
 879     (and (re-search-backward mh-letter-header-field-regexp nil t)
 880          (intern (downcase (match-string 1))))))
 881
 882 (defun mh-folder-expand-at-point ()
 883   "Do folder name completion in Fcc header field."
 884   (let* ((beg (mh-beginning-of-word))
 885          (end (save-excursion
 886                 (goto-char beg)
 887                 (mh-beginning-of-word -1))))
 888     (when (>= end (point))
 889       (list beg (if (fboundp 'completion-at-point) end (point))
 890             #'mh-folder-completion-function))))
 891
 892 ;;;###mh-autoload
 893 (defun mh-complete-word (word choices begin end)
 894   "Complete WORD from CHOICES.
 895 Any match found replaces the text from BEGIN to END."
 896   (let ((completion (try-completion word choices))
 897         (completions-buffer "*Completions*"))
 898     (cond ((eq completion t)
 899            (ignore-errors
 900              (kill-buffer completions-buffer))
 901            (message "Completed: %s" word))
 902           ((null completion)
 903            (ignore-errors
 904              (kill-buffer completions-buffer))
 905            (message "No completion for %s" word))
 906           ((stringp completion)
 907            (if (equal word completion)
 908                (with-output-to-temp-buffer completions-buffer
 909                  (mh-display-completion-list
 910                   (all-completions word choices)
 911                   ;; The `common-subtring' arg only works if it's a prefix.
 912                   (unless (and (functionp choices)
 913                                (let ((bounds
 914                                       (funcall choices
 915                                                word nil '(boundaries . ""))))
 916                                  (and (eq 'boundaries (car-safe bounds))
 917                                       (< 0 (cadr bounds)))))
 918                     word)))
 919              (ignore-errors
 920                (kill-buffer completions-buffer))
 921              (delete-region begin end)
 922              (insert completion))))))
 923
 924 (defun mh-file-is-vcard-p (file)
 925   "Return t if FILE is a .vcf vcard."
 926   (let ((case-fold-search t))
 927     (and (stringp file)
 928          (file-exists-p file)
 929          (or (and (not (mh-have-file-command))
 930                   (not (null (string-match "\.vcf$" file))))
 931              (string-equal "text/x-vcard" (mh-file-mime-type file))))))
 932
 933 ;;;###mh-autoload
 934 (defun mh-letter-toggle-header-field-display-button (event)
 935   "Toggle header field display at location of EVENT.
 936 This function does the same thing as
 937 `mh-letter-toggle-header-field-display' except that it is
 938 callable from a mouse button."
 939   (interactive "e")
 940   (mh-do-at-event-location event
 941     (mh-letter-toggle-header-field-display nil)))
 942
 943 (defun mh-extract-from-attribution ()
 944   "Extract phrase or comment from From header field."
 945   (save-excursion
 946     (if (not (mh-goto-header-field "From: "))
 947         nil
 948       (skip-chars-forward " ")
 949       (cond
 950        ((looking-at "\"\\([^\"\n]+\\)\" \\(<.+>\\)")
 951         (format "%s %s " (match-string 1)(match-string 2)))
 952        ((looking-at "\\([^<\n]+<.+>\\)$")
 953         (format "%s " (match-string 1)))
 954        ((looking-at "\\([^ ]+@[^ ]+\\) +(\\(.+\\))$")
 955         (format "%s <%s> " (match-string 2)(match-string 1)))
 956        ((looking-at " *\\(.+\\)$")
 957         (format "%s " (match-string 1)))))))
 958
 959 (defun mh-insert-prefix-string (mh-ins-string)
 960   "Insert prefix string before each line in buffer.
 961 The inserted letter is cited using `sc-cite-original' if
 962 `mh-yank-behavior' is one of 'supercite or 'autosupercite.
 963 Otherwise, simply insert MH-INS-STRING before each line."
 964   (goto-char (point-min))
 965   (cond ((or (eq mh-yank-behavior 'supercite)
 966              (eq mh-yank-behavior 'autosupercite))
 967          (sc-cite-original))
 968         (mail-citation-hook
 969          (run-hooks 'mail-citation-hook))
 970         (mh-yank-hooks                  ;old hook name
 971          (run-hooks 'mh-yank-hooks))
 972         (t
 973          (or (bolp) (forward-line 1))
 974          (while (< (point) (point-max))
 975            (insert mh-ins-string)
 976            (forward-line 1))
 977          (goto-char (point-min)))))     ;leave point like sc-cite-original
 978
 979 (provide 'mh-letter)
 980
 981 ;; Local Variables:
 982 ;; indent-tabs-mode: nil
 983 ;; sentence-end-double-space: nil
 984 ;; End:
 985
 986 ;;; mh-letter.el ends here