lisp/mh-e/mh-letter.el

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