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