lisp/mh-e/mh-letter.el

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