lisp/mh-e/mh-letter.el

   1 ;;; mh-letter.el --- MH-Letter mode
   2
   3 ;; Copyright (C) 1993, 1995, 1997,
   4 ;;  2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
   5
   6 ;; Author: Bill Wohler <wohler@newt.com>
   7 ;; Maintainer: Bill Wohler <wohler@newt.com>
   8 ;; Keywords: mail
   9 ;; See: mh-e.el
  10
  11 ;; This file is part of GNU Emacs.
  12
  13 ;; GNU Emacs is free software: you can redistribute it and/or modify
  14 ;; it under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation, either version 3 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     (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   ;; If text-mode-hook turned on auto-fill, tune it for messages
 350   (when auto-fill-function
 351     (make-local-variable 'auto-fill-function)
 352     (setq auto-fill-function 'mh-auto-fill-for-letter)))
 353
 354 \f
 355
 356 ;;; MH-Letter Commands
 357
 358 ;; Alphabetical.
 359 ;; See also mh-comp.el and mh-mime.el.
 360
 361 (defun mh-check-whom ()
 362   "Verify recipients, showing expansion of any aliases.
 363
 364 This command expands aliases so you can check the actual address(es)
 365 in the alias. A new buffer named \"*MH-E Recipients*\" is created with
 366 the output of \"whom\"."
 367   (interactive)
 368   (let ((file-name buffer-file-name))
 369     (save-buffer)
 370     (message "Checking recipients...")
 371     (mh-in-show-buffer (mh-recipients-buffer)
 372       (bury-buffer (current-buffer))
 373       (erase-buffer)
 374       (mh-exec-cmd-output "whom" t file-name))
 375     (message "Checking recipients...done")))
 376
 377 (defun mh-insert-letter (folder message verbatim)
 378   "Insert a message.
 379
 380 This command prompts you for the FOLDER and MESSAGE number, which
 381 defaults to the current message in that folder. It then inserts
 382 the message, indented by `mh-ins-buf-prefix' (\"> \") unless
 383 `mh-yank-behavior' is set to one of the supercite flavors in
 384 which case supercite is used to format the message. Certain
 385 undesirable header fields (see
 386 `mh-invisible-header-fields-compiled') are removed before
 387 insertion.
 388
 389 If given a prefix argument VERBATIM, the header is left intact, the
 390 message is not indented, and \"> \" is not inserted before each line.
 391 This command leaves the mark before the letter and point after it."
 392   (interactive
 393    (let* ((folder
 394            (mh-prompt-for-folder "Message from" mh-sent-from-folder nil))
 395           (default
 396             (if (equal folder mh-sent-from-folder)
 397                 (or mh-sent-from-msg (nth 0 (mh-translate-range folder "cur")))
 398               (nth 0 (mh-translate-range folder "cur"))))
 399           (message
 400            (read-string (concat "Message number"
 401                                 (or (and default
 402                                          (format " (default %d): " default))
 403                                     ": "))
 404                         nil nil
 405                         (if (numberp default)
 406                             (int-to-string default)
 407                           default))))
 408      (list folder message current-prefix-arg)))
 409   (if (equal message "")
 410       (error "No message number given"))
 411   (save-restriction
 412     (narrow-to-region (point) (point))
 413     (let ((start (point-min)))
 414       (insert-file-contents
 415        (expand-file-name message (mh-expand-file-name folder)))
 416       (when (not verbatim)
 417         (mh-clean-msg-header start mh-invisible-header-fields-compiled nil)
 418         (goto-char (point-max))         ;Needed for sc-cite-original
 419         (push-mark)                     ;Needed for sc-cite-original
 420         (goto-char (point-min))         ;Needed for sc-cite-original
 421         (mh-insert-prefix-string mh-ins-buf-prefix)))))
 422
 423 ;;;###mh-autoload
 424 (defun mh-insert-signature (&optional file)
 425   "Insert signature in message.
 426
 427 This command inserts your signature at the current cursor location.
 428
 429 By default, the text of your signature is taken from the file
 430 \"~/.signature\". You can read from other sources by changing the
 431 option `mh-signature-file-name'.
 432
 433 A signature separator (\"-- \") will be added if the signature block
 434 does not contain one and `mh-signature-separator-flag' is on.
 435
 436 The hook `mh-insert-signature-hook' is run after the signature is
 437 inserted. Hook functions may access the actual name of the file or the
 438 function used to insert the signature with `mh-signature-file-name'.
 439
 440 The signature can also be inserted using Identities (see
 441 `mh-identity-list').
 442
 443 In a program, you can pass in a signature FILE."
 444   (interactive)
 445   (save-excursion
 446     (insert "\n")
 447     (let ((mh-signature-file-name (or file mh-signature-file-name))
 448           (mh-mh-p (mh-mh-directive-present-p))
 449           (mh-mml-p (mh-mml-tag-present-p)))
 450       (save-restriction
 451         (narrow-to-region (point) (point))
 452         (cond
 453          ((mh-file-is-vcard-p mh-signature-file-name)
 454           (if (equal mh-compose-insertion 'mml)
 455               (insert "<#part type=\"text/x-vcard\" filename=\""
 456                       mh-signature-file-name
 457                       "\" disposition=inline description=VCard>\n<#/part>")
 458             (insert "#text/x-vcard; name=\""
 459                     (file-name-nondirectory mh-signature-file-name)
 460                     "\" [VCard] " (expand-file-name mh-signature-file-name))))
 461          (t
 462           (cond
 463            (mh-mh-p
 464             (insert "#\n" "Content-Description: Signature\n"))
 465            (mh-mml-p
 466             (mml-insert-tag 'part 'type "text/plain" 'disposition "inline"
 467                             'description "Signature")))
 468           (cond ((null mh-signature-file-name))
 469                 ((and (stringp mh-signature-file-name)
 470                       (file-readable-p mh-signature-file-name))
 471                  (insert-file-contents mh-signature-file-name))
 472                 ((functionp mh-signature-file-name)
 473                  (funcall mh-signature-file-name)))))
 474         (save-restriction
 475           (widen)
 476           (run-hooks 'mh-insert-signature-hook))
 477         (goto-char (point-min))
 478         (when (and (not (mh-file-is-vcard-p mh-signature-file-name))
 479                    mh-signature-separator-flag
 480                    (> (point-max) (point-min))
 481                    (not (mh-signature-separator-p)))
 482           (cond (mh-mh-p
 483                  (forward-line 2))
 484                 (mh-mml-p
 485                  (forward-line 1)))
 486           (insert mh-signature-separator))
 487         (if (not (> (point-max) (point-min)))
 488             (message "No signature found")))))
 489   (force-mode-line-update))
 490
 491 (defun mh-letter-complete (arg)
 492   "Perform completion on header field or word preceding point.
 493
 494 If the field contains addresses (for example, \"To:\" or \"Cc:\")
 495 or folders (for example, \"Fcc:\") then this command will provide
 496 alias completion. In the body of the message, this command runs
 497 `mh-letter-complete-function' instead, which is set to
 498 `ispell-complete-word' by default. This command takes a prefix
 499 argument ARG that is passed to the
 500 `mh-letter-complete-function'."
 501   (interactive "P")
 502   (let ((func nil))
 503     (cond ((not (mh-in-header-p))
 504            (funcall mh-letter-complete-function arg))
 505           ((setq func (cdr (assoc (mh-letter-header-field-at-point)
 506                                   mh-letter-complete-function-alist)))
 507            (funcall func))
 508           (t (funcall mh-letter-complete-function arg)))))
 509
 510 (defun mh-letter-complete-or-space (arg)
 511   "Perform completion or insert space.
 512
 513 Turn on the option `mh-compose-space-does-completion-flag' to use
 514 this command to perform completion in the header. Otherwise, a
 515 space is inserted; use a prefix argument ARG to specify more than
 516 one space."
 517   (interactive "p")
 518   (let ((func nil)
 519         (end-of-prev (save-excursion
 520                        (goto-char (mh-beginning-of-word))
 521                        (mh-beginning-of-word -1))))
 522     (cond ((not mh-compose-space-does-completion-flag)
 523            (self-insert-command arg))
 524           ((not (mh-in-header-p)) (self-insert-command arg))
 525           ((> (point) end-of-prev) (self-insert-command arg))
 526           ((setq func (cdr (assoc (mh-letter-header-field-at-point)
 527                                   mh-letter-complete-function-alist)))
 528            (funcall func))
 529           (t (self-insert-command arg)))))
 530
 531 (defun mh-letter-confirm-address ()
 532   "Flash alias expansion.
 533
 534 Addresses are separated by a comma\; when you press the comma,
 535 this command flashes the alias expansion in the minibuffer if
 536 `mh-alias-flash-on-comma' is turned on."
 537   (interactive)
 538   (cond ((not (mh-in-header-p)) (self-insert-command 1))
 539         ((eq (cdr (assoc (mh-letter-header-field-at-point)
 540                          mh-letter-complete-function-alist))
 541              'mh-alias-letter-expand-alias)
 542          (mh-alias-reload-maybe)
 543          (mh-alias-minibuffer-confirm-address))
 544         (t (self-insert-command 1))))
 545
 546 (defun mh-letter-next-header-field-or-indent (arg)
 547   "Cycle to next field.
 548
 549 Within the header of the message, this command moves between
 550 fields that are highlighted with the face
 551 `mh-letter-header-field', skipping those fields listed in
 552 `mh-compose-skipped-header-fields'. After the last field, this
 553 command then moves point to the message body before cycling back
 554 to the first field. If point is already past the first line of
 555 the message body, then this command indents by calling
 556 `indent-relative' with the given prefix argument ARG."
 557   (interactive "P")
 558   (let ((header-end (save-excursion
 559                       (goto-char (mh-mail-header-end))
 560                       (forward-line)
 561                       (point))))
 562     (if (> (point) header-end)
 563         (indent-relative arg)
 564       (mh-letter-next-header-field))))
 565
 566 (defun mh-letter-previous-header-field ()
 567   "Cycle to the previous header field.
 568
 569 This command moves backwards between the fields and cycles to the
 570 body of the message after the first field. Unlike the command
 571 \\[mh-letter-next-header-field-or-indent], it will always take
 572 point to the last field from anywhere in the body."
 573   (interactive)
 574   (let ((header-end (mh-mail-header-end)))
 575     (if (>= (point) header-end)
 576         (goto-char header-end)
 577       (mh-header-field-beginning))
 578     (cond ((re-search-backward mh-letter-header-field-regexp nil t)
 579            (if (mh-letter-skipped-header-field-p (match-string 1))
 580                (mh-letter-previous-header-field)
 581            (goto-char (match-end 0))
 582            (mh-letter-skip-leading-whitespace-in-header-field)))
 583           (t (goto-char header-end)
 584              (forward-line)))))
 585
 586 (defun mh-open-line ()
 587   "Insert a newline and leave point before it.
 588
 589 This command is similar to the command \\[open-line] in that it
 590 inserts a newline after point. It differs in that it also inserts
 591 the right number of quoting characters and spaces so that the
 592 next line begins in the same column as it was. This is useful
 593 when breaking up paragraphs in replies."
 594   (interactive)
 595   (let ((column (current-column))
 596         (prefix (mh-current-fill-prefix)))
 597     (if (> (length prefix) column)
 598         (message "Sorry, point seems to be within the line prefix")
 599       (newline 2)
 600       (insert prefix)
 601       (while (> column (current-column))
 602         (insert " "))
 603       (forward-line -1))))
 604
 605 (defun mh-to-fcc (&optional folder)
 606   "Move to \"Fcc:\" header field.
 607
 608 This command will prompt you for the FOLDER name in which to file
 609 a copy of the draft."
 610   (interactive (list (mh-prompt-for-folder
 611                       "Fcc"
 612                       (or (and mh-default-folder-for-message-function
 613                                (save-excursion
 614                                  (goto-char (point-min))
 615                                  (funcall
 616                                   mh-default-folder-for-message-function)))
 617                           "")
 618                       t)))
 619   (let ((last-input-char ?\C-f))
 620     (expand-abbrev)
 621     (save-excursion
 622       (mh-to-field)
 623       (insert (if (mh-folder-name-p folder)
 624                   (substring folder 1)
 625                 folder)))))
 626
 627 (defvar mh-to-field-choices '(("a" . "Mail-Reply-To:")
 628                               ("b" . "Bcc:")
 629                               ("c" . "Cc:")
 630                               ("d" . "Dcc:")
 631                               ("f" . "Fcc:")
 632                               ("l" . "Mail-Followup-To:")
 633                               ("m" . "From:")
 634                               ("r" . "Reply-To:")
 635                               ("s" . "Subject:")
 636                               ("t" . "To:"))
 637   "Alist of (final-character . field-name) choices for `mh-to-field'.")
 638
 639 (defun mh-to-field ()
 640   "Move to specified header field.
 641
 642 The field is indicated by the previous keystroke (the last
 643 keystroke of the command) according to the list in the variable
 644 `mh-to-field-choices'.
 645 Create the field if it does not exist.
 646 Set the mark to point before moving."
 647   (interactive)
 648   (expand-abbrev)
 649   (let ((target (cdr (or (assoc (char-to-string (logior last-input-char ?`))
 650                                 mh-to-field-choices)
 651                          ;; also look for a char for version 4 compat
 652                          (assoc (logior last-input-char ?`)
 653                                 mh-to-field-choices))))
 654         (case-fold-search t))
 655     (push-mark)
 656     (cond ((mh-position-on-field target)
 657            (let ((eol (point)))
 658              (skip-chars-backward " \t")
 659              (delete-region (point) eol))
 660            (if (and (not (eq (logior last-input-char ?`) ?s))
 661                     (save-excursion
 662                       (backward-char 1)
 663                       (not (looking-at "[:,]"))))
 664                (insert ", ")
 665              (insert " ")))
 666           (t
 667            (if (mh-position-on-field "To:")
 668                (forward-line 1))
 669            (insert (format "%s \n" target))
 670            (backward-char 1)))))
 671
 672 ;;;###mh-autoload
 673 (defun mh-yank-cur-msg ()
 674   "Insert the current message into the draft buffer.
 675
 676 It is often useful to insert a snippet of text from a letter that
 677 someone mailed to provide some context for your reply. This
 678 command does this by adding an attribution, yanking a portion of
 679 text from the message to which you're replying, and inserting
 680 `mh-ins-buf-prefix' (`> ') before each line.
 681
 682 The attribution consists of the sender's name and email address
 683 followed by the content of the option
 684 `mh-extract-from-attribution-verb'.
 685
 686 You can also turn on the option
 687 `mh-delete-yanked-msg-window-flag' to delete the window
 688 containing the original message after yanking it to make more
 689 room on your screen for your reply.
 690
 691 You can control how the message to which you are replying is
 692 yanked into your reply using `mh-yank-behavior'.
 693
 694 If this isn't enough, you can gain full control over the
 695 appearance of the included text by setting `mail-citation-hook'
 696 to a function that modifies it. For example, if you set this hook
 697 to `trivial-cite' (which is NOT part of Emacs), set
 698 `mh-yank-behavior' to \"Body and Header\" (see URL
 699 `http://shasta.cs.uiuc.edu/~lrclause/tc.html').
 700
 701 Note that if `mail-citation-hook' is set, `mh-ins-buf-prefix' is
 702 not inserted. If the option `mh-yank-behavior' is set to one of
 703 the supercite flavors, the hook `mail-citation-hook' is ignored
 704 and `mh-ins-buf-prefix' is not inserted."
 705   (interactive)
 706   (if (and mh-sent-from-folder
 707            (save-excursion (set-buffer mh-sent-from-folder) mh-show-buffer)
 708            (save-excursion (set-buffer mh-sent-from-folder)
 709                            (get-buffer mh-show-buffer))
 710            mh-sent-from-msg)
 711       (let ((to-point (point))
 712             (to-buffer (current-buffer)))
 713         (set-buffer mh-sent-from-folder)
 714         (if mh-delete-yanked-msg-window-flag
 715             (delete-windows-on mh-show-buffer))
 716         (set-buffer mh-show-buffer)     ; Find displayed message
 717         (let* ((from-attr (mh-extract-from-attribution))
 718                (yank-region (mh-mark-active-p nil))
 719                (mh-ins-str
 720                 (cond ((and yank-region
 721                             (or (eq 'supercite mh-yank-behavior)
 722                                 (eq 'autosupercite mh-yank-behavior)
 723                                 (eq t mh-yank-behavior)))
 724                        ;; supercite needs the full header
 725                        (concat
 726                         (buffer-substring (point-min) (mh-mail-header-end))
 727                         "\n"
 728                         (buffer-substring (region-beginning) (region-end))))
 729                       (yank-region
 730                        (buffer-substring (region-beginning) (region-end)))
 731                       ((or (eq 'body mh-yank-behavior)
 732                            (eq 'attribution mh-yank-behavior)
 733                            (eq 'autoattrib mh-yank-behavior))
 734                        (buffer-substring
 735                         (save-excursion
 736                           (goto-char (point-min))
 737                           (mh-goto-header-end 1)
 738                           (point))
 739                         (point-max)))
 740                       ((or (eq 'supercite mh-yank-behavior)
 741                            (eq 'autosupercite mh-yank-behavior)
 742                            (eq t mh-yank-behavior))
 743                        (buffer-substring (point-min) (point-max)))
 744                       (t
 745                        (buffer-substring (point) (point-max))))))
 746           (set-buffer to-buffer)
 747           (save-restriction
 748             (narrow-to-region to-point to-point)
 749             (insert (mh-filter-out-non-text mh-ins-str))
 750             (goto-char (point-max))     ;Needed for sc-cite-original
 751             (push-mark)                 ;Needed for sc-cite-original
 752             (goto-char (point-min))     ;Needed for sc-cite-original
 753             (mh-insert-prefix-string mh-ins-buf-prefix)
 754             (when (or (eq 'attribution mh-yank-behavior)
 755                       (eq 'autoattrib mh-yank-behavior))
 756               (insert from-attr)
 757               (mh-identity-insert-attribution-verb nil)
 758               (insert "\n\n"))
 759             ;; If the user has selected a region, he has already "edited" the
 760             ;; text, so leave the cursor at the end of the yanked text. In
 761             ;; either case, leave a mark at the opposite end of the included
 762             ;; text to make it easy to jump or delete to the other end of the
 763             ;; text.
 764             (push-mark)
 765             (goto-char (point-max))
 766             (if (null yank-region)
 767                 (mh-exchange-point-and-mark-preserving-active-mark)))))
 768     (error "There is no current message")))
 769
 770 \f
 771
 772 ;;; Support Routines
 773
 774 (defun mh-auto-fill-for-letter ()
 775   "Perform auto-fill for message.
 776 Header is treated specially by inserting a tab before continuation
 777 lines."
 778   (if (mh-in-header-p)
 779       (let ((fill-prefix "\t"))
 780         (do-auto-fill))
 781     (do-auto-fill)))
 782
 783 (defun mh-filter-out-non-text (string)
 784   "Return STRING but without adornments such as MIME buttons and smileys."
 785   (with-temp-buffer
 786     ;; Insert the string to filter
 787     (insert string)
 788     (goto-char (point-min))
 789
 790     ;; Remove the MIME buttons
 791     (let ((can-move-forward t)
 792           (in-button nil))
 793       (while can-move-forward
 794         (cond ((and (not (get-text-property (point) 'mh-data))
 795                     in-button)
 796                (delete-region (1- (point)) (point))
 797                (setq in-button nil))
 798               ((get-text-property (point) 'mh-data)
 799                (delete-region (point)
 800                               (save-excursion (forward-line) (point)))
 801                (setq in-button t))
 802               (t (setq can-move-forward (= (forward-line) 0))))))
 803
 804     ;; Return the contents without properties... This gets rid of emphasis
 805     ;; and smileys
 806     (buffer-substring-no-properties (point-min) (point-max))))
 807
 808 (defun mh-current-fill-prefix ()
 809   "Return the `fill-prefix' on the current line as a string."
 810   (save-excursion
 811     (beginning-of-line)
 812     ;; This assumes that the major-mode sets up adaptive-fill-regexp
 813     ;; correctly such as mh-letter-mode or sendmail.el's mail-mode.  But
 814     ;; perhaps I should use the variable and simply inserts its value here,
 815     ;; and set it locally in a let scope.  --psg
 816     (if (re-search-forward adaptive-fill-regexp nil t)
 817         (match-string 0)
 818       "")))
 819
 820 ;;;###mh-autoload
 821 (defun mh-letter-next-header-field ()
 822   "Cycle to the next header field.
 823 If we are at the last header field go to the start of the message
 824 body."
 825   (let ((header-end (mh-mail-header-end)))
 826     (cond ((>= (point) header-end) (goto-char (point-min)))
 827           ((< (point) (progn
 828                         (beginning-of-line)
 829                         (re-search-forward mh-letter-header-field-regexp
 830                                            (mh-line-end-position) t)
 831                         (point)))
 832            (beginning-of-line))
 833           (t (end-of-line)))
 834     (cond ((re-search-forward mh-letter-header-field-regexp header-end t)
 835            (if (mh-letter-skipped-header-field-p (match-string 1))
 836                (mh-letter-next-header-field)
 837              (mh-letter-skip-leading-whitespace-in-header-field)))
 838           (t (goto-char header-end)
 839              (forward-line)))))
 840
 841 ;;;###mh-autoload
 842 (defun mh-position-on-field (field &optional ignored)
 843   "Move to the end of the FIELD in the header.
 844 Move to end of entire header if FIELD not found.
 845 Returns non-nil if FIELD was found.
 846 The optional second arg is for pre-version 4 compatibility and is
 847 IGNORED."
 848   (cond ((mh-goto-header-field field)
 849          (mh-header-field-end)
 850          t)
 851         ((mh-goto-header-end 0)
 852          nil)))
 853
 854 (defun mh-letter-header-field-at-point ()
 855   "Return the header field name at point.
 856 A symbol is returned whose name is the string obtained by
 857 downcasing the field name."
 858   (save-excursion
 859     (end-of-line)
 860     (and (re-search-backward mh-letter-header-field-regexp nil t)
 861          (intern (downcase (match-string 1))))))
 862
 863 (defun mh-folder-expand-at-point ()
 864   "Do folder name completion in Fcc header field."
 865   (let* ((end (point))
 866          (beg (mh-beginning-of-word))
 867          (folder (buffer-substring-no-properties beg end))
 868          (leading-plus (and (> (length folder) 0) (equal (aref folder 0) ?+)))
 869          (choices (mapcar (lambda (x) (list x))
 870                           (mh-folder-completion-function folder nil t))))
 871     (unless leading-plus
 872       (setq folder (concat "+" folder)))
 873     (mh-complete-word folder choices beg end)))
 874
 875 ;;;###mh-autoload
 876 (defun mh-complete-word (word choices begin end)
 877   "Complete WORD from CHOICES.
 878 Any match found replaces the text from BEGIN to END."
 879   (let ((completion (try-completion word choices))
 880         (completions-buffer "*Completions*"))
 881     (cond ((eq completion t)
 882            (ignore-errors
 883              (kill-buffer completions-buffer))
 884            (message "Completed: %s" word))
 885           ((null completion)
 886            (ignore-errors
 887              (kill-buffer completions-buffer))
 888            (message "No completion for %s" word))
 889           ((stringp completion)
 890            (if (equal word completion)
 891                (with-output-to-temp-buffer completions-buffer
 892                  (mh-display-completion-list (all-completions word choices)
 893                                              word))
 894              (ignore-errors
 895                (kill-buffer completions-buffer))
 896              (delete-region begin end)
 897              (insert completion))))))
 898
 899 (defun mh-file-is-vcard-p (file)
 900   "Return t if FILE is a .vcf vcard."
 901   (let ((case-fold-search t))
 902     (and (stringp file)
 903          (file-exists-p file)
 904          (or (and (not (mh-have-file-command))
 905                   (not (null (string-match "\.vcf$" file))))
 906              (string-equal "text/x-vcard" (mh-file-mime-type file))))))
 907
 908 ;;;###mh-autoload
 909 (defun mh-letter-toggle-header-field-display-button (event)
 910   "Toggle header field display at location of EVENT.
 911 This function does the same thing as
 912 `mh-letter-toggle-header-field-display' except that it is
 913 callable from a mouse button."
 914   (interactive "e")
 915   (mh-do-at-event-location event
 916     (mh-letter-toggle-header-field-display nil)))
 917
 918 (defun mh-extract-from-attribution ()
 919   "Extract phrase or comment from From header field."
 920   (save-excursion
 921     (if (not (mh-goto-header-field "From: "))
 922         nil
 923       (skip-chars-forward " ")
 924       (cond
 925        ((looking-at "\"\\([^\"\n]+\\)\" \\(<.+>\\)")
 926         (format "%s %s " (match-string 1)(match-string 2)))
 927        ((looking-at "\\([^<\n]+<.+>\\)$")
 928         (format "%s " (match-string 1)))
 929        ((looking-at "\\([^ ]+@[^ ]+\\) +(\\(.+\\))$")
 930         (format "%s <%s> " (match-string 2)(match-string 1)))
 931        ((looking-at " *\\(.+\\)$")
 932         (format "%s " (match-string 1)))))))
 933
 934 (defun mh-insert-prefix-string (mh-ins-string)
 935   "Insert prefix string before each line in buffer.
 936 The inserted letter is cited using `sc-cite-original' if
 937 `mh-yank-behavior' is one of 'supercite or 'autosupercite.
 938 Otherwise, simply insert MH-INS-STRING before each line."
 939   (goto-char (point-min))
 940   (cond ((or (eq mh-yank-behavior 'supercite)
 941              (eq mh-yank-behavior 'autosupercite))
 942          (sc-cite-original))
 943         (mail-citation-hook
 944          (run-hooks 'mail-citation-hook))
 945         (mh-yank-hooks                  ;old hook name
 946          (run-hooks 'mh-yank-hooks))
 947         (t
 948          (or (bolp) (forward-line 1))
 949          (while (< (point) (point-max))
 950            (insert mh-ins-string)
 951            (forward-line 1))
 952          (goto-char (point-min)))))     ;leave point like sc-cite-original
 953
 954 (provide 'mh-letter)
 955
 956 ;; Local Variables:
 957 ;; indent-tabs-mode: nil
 958 ;; sentence-end-double-space: nil
 959 ;; End:
 960
 961 ;; arch-tag: 0548632c-aadb-4e3b-bb80-bbd62ff90bf3
 962 ;;; mh-letter.el ends here