1 ;;; mh-comp.el --- MH-E functions for composing messages
3 ;; Copyright (C) 1993, 1995, 1997,
4 ;; 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
6 ;; Author: Bill Wohler <wohler@newt.com>
7 ;; Maintainer: Bill Wohler <wohler@newt.com>
11 ;; This file is part of GNU Emacs.
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)
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.
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.
30 ;; Internal support for MH-E package.
36 (eval-when-compile (require 'mh-acros
))
42 (eval-when (compile load eval
)
43 (ignore-errors (require 'mailabbrev
)))
45 ;; Shush the byte-compiler
46 (defvar adaptive-fill-first-line-regexp
)
47 (defvar font-lock-defaults
)
49 (defvar sendmail-coding-system
)
50 (defvar mh-identity-list
)
51 (defvar mh-identity-default
)
52 (defvar mh-mml-mode-default
)
53 (defvar mh-identity-menu
)
58 (autoload 'mail-mode-fill-paragraph
"sendmail")
59 (autoload 'mm-handle-displayed-p
"mm-decode")
61 (autoload 'sc-cite-original
"sc"
62 "Workhorse citing function which performs the initial citation.
63 This is callable from the various mail and news readers' reply
64 function according to the agreed upon standard. See `sc-describe'
65 for more details. `sc-cite-original' does not do any yanking of the
66 original message but it does require a few things:
68 1) The reply buffer is the current buffer.
70 2) The original message has been yanked and inserted into the
73 3) Verbose mail headers from the original message have been
74 inserted into the reply buffer directly before the text of the
77 4) Point is at the beginning of the verbose headers.
79 5) Mark is at the end of the body of text to be cited.
81 For Emacs 19's, the region need not be active (and typically isn't
82 when this function is called. Also, the hook `sc-pre-hook' is run
83 before, and `sc-post-hook' is run after the guts of this function.")
87 ;;; Site customization (see also mh-utils.el):
89 (defvar mh-send-prog
"send"
90 "Name of the MH send program.
91 Some sites need to change this because of a name conflict.")
93 (defvar mh-redist-background nil
94 "If non-nil redist will be done in background like send.
95 This allows transaction log to be visible if -watch, -verbose or
100 ;;; Scan Line Formats
102 (defvar mh-note-repl ?-
103 "Messages that have been replied to are marked by this character.")
105 (defvar mh-note-forw ?F
106 "Messages that have been forwarded are marked by this character.")
108 (defvar mh-note-dist ?R
109 "Messages that have been redistributed are marked by this character.")
111 (defvar mh-yank-hooks nil
112 "Obsolete hook for modifying a citation just inserted in the mail buffer.
114 Each hook function can find the citation between point and mark.
115 And each hook function should leave point and mark around the
116 citation text as modified.
118 This is a normal hook, misnamed for historical reasons. It is
119 semi-obsolete and is only used if `mail-citation-hook' is nil.")
121 (defvar mh-comp-formfile
"components"
122 "Name of file to be used as a skeleton for composing messages.
124 Default is \"components\".
126 If not an absolute file name, the file is searched for first in the
127 user's MH directory, then in the system MH lib directory.")
129 (defvar mh-repl-formfile
"replcomps"
130 "Name of file to be used as a skeleton for replying to messages.
132 Default is \"replcomps\".
134 If not an absolute file name, the file is searched for first in the
135 user's MH directory, then in the system MH lib directory.")
137 (defvar mh-repl-group-formfile
"replgroupcomps"
138 "Name of file to be used as a skeleton for replying to messages.
140 Default is \"replgroupcomps\".
142 This file is used to form replies to the sender and all recipients of
143 a message. Only used if `(mh-variant-p 'nmh)' is non-nil.
144 If not an absolute file name, the file is searched for first in the
145 user's MH directory, then in the system MH lib directory.")
147 (defvar mh-rejected-letter-start
150 '("Content-Type: message/rfc822" ;MIME MDN
151 "------ This is a copy of the message, including all the headers. ------";from exim
152 "--- Below this line is a copy of the message."; from qmail
153 " ----- Unsent message follows -----" ;from sendmail V5
154 " --------Unsent Message below:" ; from sendmail at BU
155 " ----- Original message follows -----" ;from sendmail V8
156 "------- Unsent Draft" ;from MH itself
157 "---------- Original Message ----------" ;from zmailer
158 " --- The unsent message follows ---" ;from AIX mail system
159 " Your message follows:" ;from MMDF-II
160 "Content-Description: Returned Content" ;1993 KJ sendmail
163 (defvar mh-new-draft-cleaned-headers
164 "^Date:\\|^Received:\\|^Message-Id:\\|^From:\\|^Sender:\\|^Errors-To:\\|^Delivery-Date:\\|^Return-Path:"
165 "Regexp of header lines to remove before offering a message as a new draft\\<mh-folder-mode-map>.
166 Used by the \\[mh-edit-again] and \\[mh-extract-rejected-mail] commands.")
168 (defvar mh-to-field-choices
'(("t" .
"To:") ("s" .
"Subject:") ("c" .
"Cc:")
169 ("b" .
"Bcc:") ("f" .
"Fcc:") ("r" .
"From:")
171 "Alist of (final-character . field-name) choices for `mh-to-field'.")
173 (defvar mh-letter-mode-map
(copy-keymap text-mode-map
)
174 "Keymap for composing mail.")
176 (defvar mh-letter-mode-syntax-table nil
177 "Syntax table used by MH-E while in MH-Letter mode.")
179 (if mh-letter-mode-syntax-table
181 (setq mh-letter-mode-syntax-table
182 (make-syntax-table text-mode-syntax-table
))
183 (modify-syntax-entry ?%
"." mh-letter-mode-syntax-table
))
185 (defvar mh-sent-from-folder nil
186 "Folder of msg assoc with this letter.")
188 (defvar mh-sent-from-msg nil
189 "Number of msg assoc with this letter.")
191 (defvar mh-send-args nil
192 "Extra args to pass to \"send\" command.")
194 (defvar mh-annotate-char nil
195 "Character to use to annotate `mh-sent-from-msg'.")
197 (defvar mh-annotate-field nil
198 "Field name for message annotation.")
200 (defvar mh-insert-auto-fields-done-local nil
201 "Buffer-local variable set when `mh-insert-auto-fields' called successfully.")
202 (make-variable-buffer-local 'mh-insert-auto-fields-done-local
)
206 "Compose a message with the MH mail system.
207 See `mh-send' for more details on composing mail."
210 (call-interactively 'mh-send
))
213 (defun mh-smail-other-window ()
214 "Compose a message with the MH mail system in other window.
215 See `mh-send' for more details on composing mail."
218 (call-interactively 'mh-send-other-window
))
220 (defvar mh-error-if-no-draft nil
) ;raise error over using old draft
223 (defun mh-smail-batch (&optional to subject other-headers
&rest ignored
)
224 "Compose a message with the MH mail system.
226 This function does not prompt the user for any header fields, and
227 thus is suitable for use by programs that want to create a mail
228 buffer. Users should use \\[mh-smail] to compose mail.
230 Optional arguments for setting certain fields include TO,
231 SUBJECT, and OTHER-HEADERS. Additional arguments are IGNORED.
233 This function remains for Emacs 21 compatibility. New
234 applications should use `mh-user-agent-compose'."
236 (let ((mh-error-if-no-draft t
))
237 (mh-send (or to
"") "" (or subject
""))))
240 (define-mail-user-agent 'mh-e-user-agent
241 'mh-user-agent-compose
'mh-send-letter
'mh-fully-kill-draft
242 'mh-before-send-letter-hook
)
245 (defun mh-user-agent-compose (&optional to subject other-headers continue
246 switch-function yank-action
248 "Set up mail composition draft with the MH mail system.
249 This is the `mail-user-agent' entry point to MH-E. This function
250 conforms to the contract specified by `define-mail-user-agent'
251 which means that this function should accept the same arguments
254 The optional arguments TO and SUBJECT specify recipients and the
255 initial Subject field, respectively.
257 OTHER-HEADERS is an alist specifying additional header fields.
258 Elements look like (HEADER . VALUE) where both HEADER and VALUE
261 CONTINUE, SWITCH-FUNCTION, YANK-ACTION and SEND-ACTIONS are
264 (let ((mh-error-if-no-draft t
))
265 (mh-send to
"" subject
)
267 (mh-insert-fields (concat (car (car other-headers
)) ":")
268 (cdr (car other-headers
)))
269 (setq other-headers
(cdr other-headers
)))))
272 (defun mh-edit-again (message)
273 "Edit a MESSAGE to send it again.
275 If you don't complete a draft for one reason or another, and if
276 the draft buffer is no longer available, you can pick your draft
277 up again with this command. If you don't use a draft folder, your
278 last \"draft\" file will be used. If you use draft folders,
279 you'll need to visit the draft folder with \"\\[mh-visit-folder]
280 drafts <RET>\", use \\[mh-next-undeleted-msg] to move to the
281 appropriate message, and then use \\[mh-edit-again] to prepare
282 the message for editing.
284 This command can also be used to take messages that were sent to
285 you and to send them to more people.
287 Don't use this command to re-edit a message from a Mailer-Daemon
288 who complained that your mail wasn't posted for some reason or
289 another (see `mh-extract-rejected-mail').
291 The default message is the current message.
294 (interactive (list (mh-get-msg-num t
)))
295 (let* ((from-folder mh-current-folder
)
296 (config (current-window-configuration))
298 (cond ((and mh-draft-folder
(equal from-folder mh-draft-folder
))
299 (pop-to-buffer (find-file-noselect (mh-msg-filename message
))
301 (rename-buffer (format "draft-%d" message
))
302 ;; Make buffer writable...
303 (setq buffer-read-only nil
)
304 ;; If buffer was being used to display the message reinsert
306 (when (eq major-mode
'mh-show-mode
)
308 (insert-file-contents buffer-file-name
))
311 (mh-read-draft "clean-up" (mh-msg-filename message
) nil
)))))
312 (mh-clean-msg-header (point-min) mh-new-draft-cleaned-headers nil
)
313 (mh-insert-header-separator)
314 (goto-char (point-min))
316 (mh-compose-and-send-mail draft
"" from-folder nil nil nil nil nil nil
318 (mh-letter-mode-message)
319 (mh-letter-adjust-point)))
322 (defun mh-extract-rejected-mail (message)
323 "Edit a MESSAGE that was returned by the mail system.
325 This command prepares the message for editing by removing the
326 Mailer-Daemon envelope and unneeded header fields. Fix whatever
327 addressing problem you had, and send the message again with
330 The default message is the current message.
333 (interactive (list (mh-get-msg-num t
)))
334 (let ((from-folder mh-current-folder
)
335 (config (current-window-configuration))
336 (draft (mh-read-draft "extraction" (mh-msg-filename message
) nil
)))
337 (goto-char (point-min))
338 (cond ((re-search-forward mh-rejected-letter-start nil t
)
339 (skip-chars-forward " \t\n")
340 (delete-region (point-min) (point))
341 (mh-clean-msg-header (point-min) mh-new-draft-cleaned-headers nil
))
343 (message "Does not appear to be a rejected letter")))
344 (mh-insert-header-separator)
345 (goto-char (point-min))
347 (mh-compose-and-send-mail draft
"" from-folder message
348 (mh-get-header-field "To:")
349 (mh-get-header-field "From:")
350 (mh-get-header-field "Cc:")
352 (mh-letter-mode-message)))
355 (defun mh-forward (to cc
&optional range
)
358 You are prompted for the TO and CC recipients. You are given a
359 draft to edit that looks like it would if you had run the MH
360 command \"forw\". You can then add some text.
362 You can forward several messages by using a RANGE. All of the
363 messages in the range are inserted into your draft. Check the
364 documentation of `mh-interactive-range' to see how RANGE is read
367 The hook `mh-forward-hook' is called on the draft.
369 See also `mh-compose-forward-as-mime-flag',
370 `mh-forward-subject-format', and `mh-send'."
371 (interactive (list (mh-interactive-read-address "To: ")
372 (mh-interactive-read-address "Cc: ")
373 (mh-interactive-range "Forward")))
374 (let* ((folder mh-current-folder
)
375 (msgs (mh-range-to-msg-list range
))
376 (config (current-window-configuration))
377 (fwd-msg-file (mh-msg-filename (car msgs
) folder
))
378 ;; forw always leaves file in "draft" since it doesn't have -draft
379 (draft-name (expand-file-name "draft" mh-user-path
))
380 (draft (cond ((or (not (file-exists-p draft-name
))
381 (y-or-n-p "The file 'draft' exists. Discard it? "))
382 (mh-exec-cmd "forw" "-build"
383 (if (and (mh-variant-p 'nmh
)
384 mh-compose-forward-as-mime-flag
)
387 (mh-coalesce-msg-list msgs
))
389 (mh-read-draft "" draft-name t
)
390 (mh-insert-fields "To:" to
"Cc:" cc
)
393 (mh-read-draft "" draft-name nil
)))))
397 (set-buffer (get-buffer-create mh-temp-buffer
))
399 (insert-file-contents fwd-msg-file
)
400 (setq orig-from
(mh-get-header-field "From:"))
401 (setq orig-subject
(mh-get-header-field "Subject:")))
403 (mh-forwarded-letter-subject orig-from orig-subject
)))
404 (mh-insert-fields "Subject:" forw-subject
)
405 (goto-char (point-min))
406 ;; If using MML, translate MH-style directive
407 (if (equal mh-compose-insertion
'mml
)
409 (goto-char (mh-mail-header-end))
412 "^#forw \\[\\([^]]+\\)\\] \\(+\\S-+\\) \\(.*\\)$"
414 (let ((description (if (equal (match-string 1)
415 "forwarded messages")
416 "forwarded message %d"
418 (msgs (split-string (match-string 3)))
421 (delete-region (point) (progn (forward-line 1) (point)))
424 (mh-mml-forward-message (format description i
)
426 ;; Postition just before forwarded message
427 (if (re-search-forward "^------- Forwarded Message" nil t
)
429 (goto-char (mh-mail-header-end))
431 (delete-other-windows)
432 (mh-add-msgs-to-seq msgs
'forwarded t
)
433 (mh-compose-and-send-mail draft
"" folder msgs
435 mh-note-forw
"Forwarded:"
437 (mh-letter-mode-message)
438 (mh-letter-adjust-point)
439 (run-hooks 'mh-forward-hook
)))))
441 (defun mh-forwarded-letter-subject (from subject
)
442 "Return a Subject suitable for a forwarded message.
443 Original message has headers FROM and SUBJECT."
444 (let ((addr-start (string-match "<" from
))
445 (comment (string-match "(" from
)))
446 (cond ((and addr-start
(> addr-start
0))
447 ;; Full Name <luser@host>
448 (setq from
(substring from
0 (1- addr-start
))))
450 ;; luser@host (Full Name)
451 (setq from
(substring from
(1+ comment
) (1- (length from
)))))))
452 (format mh-forward-subject-format from subject
))
455 (defun mh-redistribute (to cc
&optional message
)
456 "Redistribute a message.
458 This command is similar in function to forwarding mail, but it
459 does not allow you to edit the message, nor does it add your name
460 to the \"From\" header field. It appears to the recipient as if
461 the message had come from the original sender. When you run this
462 command, you are prompted for the TO and CC recipients. The
463 default MESSAGE is the current message.
465 Also investigate the \\[mh-edit-again] command for another way to
466 redistribute messages.
468 See also `mh-redist-full-contents-flag'."
469 (interactive (list (mh-read-address "Redist-To: ")
470 (mh-read-address "Redist-Cc: ")
473 (setq message
(mh-get-msg-num t
)))
474 (save-window-excursion
475 (let ((folder mh-current-folder
)
476 (draft (mh-read-draft "redistribution"
477 (if mh-redist-full-contents-flag
478 (mh-msg-filename message
)
481 (mh-goto-header-end 0)
482 (insert "Resent-To: " to
"\n")
483 (if (not (equal cc
"")) (insert "Resent-cc: " cc
"\n"))
486 "^Message-Id:\\|^Received:\\|^Return-Path:\\|^Sender:\\|^Date:\\|^From:"
489 (message "Redistributing...")
490 (let ((env "mhdist=1"))
491 ;; Setup environment...
492 (setq env
(concat env
" mhaltmsg="
493 (if mh-redist-full-contents-flag
495 (mh-msg-filename message folder
))))
496 (unless mh-redist-full-contents-flag
497 (setq env
(concat env
" mhannotate=1")))
499 (if mh-redist-background
500 (mh-exec-cmd-env-daemon env mh-send-prog nil buffer-file-name
)
501 (mh-exec-cmd-error env mh-send-prog
"-push" buffer-file-name
))
503 (mh-annotate-msg message folder mh-note-dist
504 "-component" "Resent:"
505 "-text" (format "\"%s %s\"" to cc
)))
507 (message "Redistributing...done"))))
509 (defun mh-show-buffer-message-number (&optional buffer
)
510 "Message number of displayed message in corresponding show buffer.
512 Return nil if show buffer not displayed.
513 If in `mh-letter-mode', don't display the message number being replied
514 to, but rather the message number of the show buffer associated with
515 our originating folder buffer.
516 Optional argument BUFFER can be used to specify the buffer."
520 (cond ((eq major-mode
'mh-show-mode
)
521 (let ((number-start (mh-search-from-end ?
/ buffer-file-name
)))
522 (car (read-from-string (substring buffer-file-name
523 (1+ number-start
))))))
524 ((and (eq major-mode
'mh-folder-mode
)
526 (get-buffer mh-show-buffer
))
527 (mh-show-buffer-message-number mh-show-buffer
))
528 ((and (eq major-mode
'mh-letter-mode
)
530 (get-buffer mh-sent-from-folder
))
531 (mh-show-buffer-message-number mh-sent-from-folder
))
536 (defun mh-reply (message &optional reply-to includep
)
539 When you reply to a message, you are first prompted with \"Reply
540 to whom?\" (unless the optional argument REPLY-TO is provided).
541 You have several choices here.
543 Response Reply Goes To
545 from The person who sent the message. This is the
546 default, so <RET> is sufficient.
548 to Replies to the sender, plus all recipients in the
549 \"To:\" header field.
552 cc Forms a reply to the sender, plus all recipients.
554 Depending on your answer, \"repl\" is given a different argument
555 to form your reply. Specifically, a choice of \"from\" or none at
556 all runs \"repl -nocc all\", and a choice of \"to\" runs \"repl
557 -cc to\". Finally, either \"cc\" or \"all\" runs \"repl -cc all
560 Two windows are then created. One window contains the message to
561 which you are replying in an MH-Show buffer. Your draft, in
562 MH-Letter mode (see `mh-letter-mode'), is in the other window.
564 If you supply a prefix argument INCLUDEP, the message you are
565 replying to is inserted in your reply after having first been run
566 through \"mhl\" with the format file \"mhl.reply\".
568 Alternatively, you can customize the option `mh-yank-behavior'
569 and choose one of its \"Automatically\" variants to do the same
570 thing. If you do so, the prefix argument has no effect.
572 Another way to include the message automatically in your draft is
573 to use \"repl: -filter repl.filter\" in your MH profile.
575 If you wish to customize the header or other parts of the reply
576 draft, please see \"repl\" and \"mh-format\".
578 See also `mh-reply-show-message-flag',
579 `mh-reply-default-reply-to', and `mh-send'."
582 (let ((minibuffer-help-form
583 "from => Sender only\nto => Sender and primary recipients\ncc or all => Sender and all recipients"))
584 (or mh-reply-default-reply-to
585 (completing-read "Reply to whom: [from] "
586 '(("from") ("to") ("cc") ("all"))
590 (let* ((folder mh-current-folder
)
591 (show-buffer mh-show-buffer
)
592 (config (current-window-configuration))
593 (group-reply (or (equal reply-to
"cc") (equal reply-to
"all")))
594 (form-file (cond ((and (mh-variant-p 'nmh
'mu-mh
) group-reply
595 (stringp mh-repl-group-formfile
))
596 mh-repl-group-formfile
)
597 ((stringp mh-repl-formfile
) mh-repl-formfile
)
599 (message "Composing a reply...")
600 (mh-exec-cmd "repl" "-build" "-noquery" "-nodraftfolder"
602 (list "-form" form-file
))
603 mh-current-folder message
604 (cond ((or (equal reply-to
"from") (equal reply-to
""))
606 ((equal reply-to
"to")
608 (group-reply (if (mh-variant-p 'nmh
'mu-mh
)
609 '("-group" "-nocc" "me")
610 '("-cc" "all" "-nocc" "me"))))
611 (cond ((or (eq mh-yank-behavior
'autosupercite
)
612 (eq mh-yank-behavior
'autoattrib
))
614 (includep '("-filter" "mhl.reply"))
616 (let ((draft (mh-read-draft "reply"
617 (expand-file-name "reply" mh-user-path
)
619 (delete-other-windows)
622 (let ((to (mh-get-header-field "To:"))
623 (subject (mh-get-header-field "Subject:"))
624 (cc (mh-get-header-field "Cc:")))
625 (goto-char (point-min))
626 (mh-goto-header-end 1)
628 (not mh-reply-show-message-flag
)
629 (mh-in-show-buffer (show-buffer)
630 (mh-display-msg message folder
)))
631 (mh-add-msgs-to-seq message
'answered t
)
632 (message "Composing a reply...done")
633 (mh-compose-and-send-mail draft
"" folder message to subject cc
634 mh-note-repl
"Replied:" config
))
635 (when (and (or (eq 'autosupercite mh-yank-behavior
)
636 (eq 'autoattrib mh-yank-behavior
))
637 (eq (mh-show-buffer-message-number) mh-sent-from-msg
))
640 (mh-letter-mode-message))))
643 (defun mh-send (to cc subject
)
646 Your letter appears in an Emacs buffer whose mode is
647 MH-Letter (see `mh-letter-mode').
649 The arguments TO, CC, and SUBJECT can be used to prefill the
650 draft fields or suppress the prompts if `mh-compose-prompt-flag'
651 is on. They are also passed to the function set in the option
652 `mh-compose-letter-function'.
654 See also `mh-insert-x-mailer-flag' and `mh-letter-mode-hook'.
656 Outside of an MH-Folder buffer (`mh-folder-mode'), you must call
657 either \\[mh-smail] or \\[mh-smail-other-window] to compose a new
660 (mh-interactive-read-address "To: ")
661 (mh-interactive-read-address "Cc: ")
662 (mh-interactive-read-string "Subject: ")))
663 (let ((config (current-window-configuration)))
664 (delete-other-windows)
665 (mh-send-sub to cc subject config
)))
668 (defun mh-send-other-window (to cc subject
)
669 "Compose a message in another window.
671 See `mh-send' for more information and a description of how the
672 TO, CC, and SUBJECT arguments are used."
674 (mh-interactive-read-address "To: ")
675 (mh-interactive-read-address "Cc: ")
676 (mh-interactive-read-string "Subject: ")))
677 (let ((pop-up-windows t
))
678 (mh-send-sub to cc subject
(current-window-configuration))))
680 (defun mh-send-sub (to cc subject config
)
681 "Do the real work of composing and sending a letter.
682 Expects the TO, CC, and SUBJECT fields as arguments.
683 CONFIG is the window configuration before sending mail."
684 (let ((folder mh-current-folder
)
685 (msg-num (mh-get-msg-num nil
)))
686 (message "Composing a message...")
687 (let ((draft (mh-read-draft
693 (expand-file-name mh-comp-formfile mh-user-path
)))
697 (expand-file-name mh-comp-formfile mh-lib
)))
701 (expand-file-name mh-comp-formfile
702 ;; What is this mh-etc ?? -sm
703 ;; This is dead code, so
705 ;(and (boundp 'mh-etc) mh-etc)
709 (error "Can't find components file \"%s\""
712 (mh-insert-fields "To:" to
"Subject:" subject
"Cc:" cc
)
713 (goto-char (point-max))
714 (mh-compose-and-send-mail draft
"" folder msg-num
717 (mh-letter-mode-message)
718 (mh-letter-adjust-point))))
720 (defun mh-read-draft (use initial-contents delete-contents-file
)
721 "Read draft file into a draft buffer and make that buffer the current one.
723 USE is a message used for prompting about the intended use of the
725 INITIAL-CONTENTS is filename that is read into an empty buffer, or nil
726 if buffer should not be modified. Delete the initial-contents file if
727 DELETE-CONTENTS-FILE flag is set.
728 Returns the draft folder's name.
729 If the draft folder facility is enabled in ~/.mh_profile, a new buffer
730 is used each time and saved in the draft folder. The draft file can
732 (cond (mh-draft-folder
733 (let ((orig-default-dir default-directory
)
734 (draft-file-name (mh-new-draft-name)))
735 (pop-to-buffer (generate-new-buffer
737 (file-name-nondirectory draft-file-name
))))
739 (insert-file-contents draft-file-name t
)
741 (setq default-directory orig-default-dir
)))
743 (let ((draft-name (expand-file-name "draft" mh-user-path
)))
744 (pop-to-buffer "draft") ; Create if necessary
745 (if (buffer-modified-p)
746 (if (y-or-n-p "Draft has been modified; kill anyway? ")
747 (set-buffer-modified-p nil
)
748 (error "Draft preserved")))
749 (setq buffer-file-name draft-name
)
750 (clear-visited-file-modtime)
752 (cond ((and (file-exists-p draft-name
)
753 (not (equal draft-name initial-contents
)))
754 (insert-file-contents draft-name
)
755 (delete-file draft-name
))))))
756 (cond ((and initial-contents
757 (or (zerop (buffer-size))
759 (format "A draft exists. Use for %s? " use
))
760 (if mh-error-if-no-draft
761 (error "A prior draft exists"))
764 (insert-file-contents initial-contents
)
765 (if delete-contents-file
(delete-file initial-contents
))))
768 (save-buffer)) ; Do not reuse draft name
771 (defun mh-new-draft-name ()
772 "Return the pathname of folder for draft messages."
774 (mh-exec-cmd-quiet t
"mhpath" mh-draft-folder
"new")
775 (buffer-substring (point-min) (1- (point-max)))))
777 (defun mh-annotate-msg (msg buffer note
&rest args
)
778 "Mark MSG in BUFFER with character NOTE and annotate message with ARGS.
779 MSG can be a message number, a list of message numbers, or a
781 (apply 'mh-exec-cmd
"anno" buffer
782 (if (listp msg
) (append msg args
) (cons msg args
)))
784 (cond ((get-buffer buffer
) ; Buffer may be deleted
786 (mh-iterate-on-range nil msg
788 (+ mh-cmd-note mh-scan-field-destination-offset
)))))))
790 (defun mh-insert-fields (&rest name-values
)
791 "Insert the NAME-VALUES pairs in the current buffer.
792 If the field exists, append the value to it.
793 Do not insert any pairs whose value is the empty string."
794 (let ((case-fold-search t
))
796 (let ((field-name (car name-values
))
797 (value (car (cdr name-values
))))
798 (if (not (string-match "^.*:$" field-name
))
799 (setq field-name
(concat field-name
":")))
800 (cond ((equal value
"")
802 ((mh-position-on-field field-name
)
803 (insert " " (or value
"")))
805 (insert field-name
" " value
"\n")))
806 (setq name-values
(cdr (cdr name-values
)))))))
808 (defun mh-position-on-field (field &optional ignored
)
809 "Move to the end of the FIELD in the header.
810 Move to end of entire header if FIELD not found.
811 Returns non-nil iff FIELD was found.
812 The optional second arg is for pre-version 4 compatibility and is
814 (cond ((mh-goto-header-field field
)
815 (mh-header-field-end)
817 ((mh-goto-header-end 0)
821 (defun mh-get-header-field (field)
822 "Find and return the body of FIELD in the mail header.
823 Returns the empty string if the field is not in the header of the
825 (if (mh-goto-header-field field
)
827 (skip-chars-forward " \t") ;strip leading white space in body
828 (let ((start (point)))
829 (mh-header-field-end)
830 (buffer-substring-no-properties start
(point))))
833 (fset 'mh-get-field
'mh-get-header-field
) ;MH-E 4 compatibility
835 (defun mh-goto-header-field (field)
836 "Move to FIELD in the message header.
837 Move to the end of the FIELD name, which should end in a colon.
838 Returns t if found, nil if not."
839 (goto-char (point-min))
840 (let ((case-fold-search t
)
841 (headers-end (save-excursion
842 (mh-goto-header-end 0)
844 (re-search-forward (format "^%s" field
) headers-end t
)))
846 (defun mh-goto-header-end (arg)
847 "Move the cursor ARG lines after the header."
848 (if (re-search-forward "^-*$" nil nil
)
851 (defun mh-extract-from-header-value ()
852 "Extract From: string from header."
854 (if (not (mh-goto-header-field "From:"))
856 (skip-chars-forward " \t")
857 (buffer-substring-no-properties
858 (point) (progn (mh-header-field-end)(point))))))
862 ;;; Mode for composing and sending a draft message.
864 (put 'mh-letter-mode
'mode-class
'special
)
866 ;; Menu extracted from mh-menubar.el V1.1 (31 July 2001)
867 (eval-when-compile (defvar mh-letter-menu nil
))
869 mh-letter-menu mh-letter-mode-map
"Menu for MH-E letter mode."
871 ["Send This Draft" mh-send-letter t
]
872 ["Split Current Line" mh-open-line t
]
873 ["Check Recipient" mh-check-whom t
]
874 ["Yank Current Message" mh-yank-cur-msg t
]
875 ["Insert a Message..." mh-insert-letter t
]
876 ["Insert Signature" mh-insert-signature t
]
877 ("Encrypt/Sign Message"
879 mh-mml-secure-message-sign mh-pgp-support-flag
]
881 mh-mml-secure-message-encrypt mh-pgp-support-flag
]
882 ["Sign+Encrypt Message"
883 mh-mml-secure-message-signencrypt mh-pgp-support-flag
]
885 mh-mml-unsecure-message mh-pgp-support-flag
]
888 ["PGP (MIME)" (setq mh-mml-method-default
"pgpmime")
890 :selected
(equal mh-mml-method-default
"pgpmime")]
891 ["PGP" (setq mh-mml-method-default
"pgp")
893 :selected
(equal mh-mml-method-default
"pgp")]
894 ["S/MIME" (setq mh-mml-method-default
"smime")
896 :selected
(equal mh-mml-method-default
"smime")]
898 ["Save Method as Default"
899 (customize-save-variable 'mh-mml-method-default mh-mml-method-default
) t
]
901 ["Compose Insertion..." mh-compose-insertion t
]
902 ["Compose Compressed tar (MH)..."
903 mh-mh-compose-external-compressed-tar t
]
904 ["Compose Get File (MH)..." mh-mh-compose-anon-ftp t
]
905 ["Compose Forward..." mh-compose-forward t
]
906 ;; The next two will have to be merged. But I also need to make sure the
907 ;; user can't mix tags of both types.
908 ["Pull in All Compositions (MH)"
909 mh-mh-to-mime
(mh-mh-directive-present-p)]
910 ["Pull in All Compositions (MML)"
911 mh-mml-to-mime
(mh-mml-tag-present-p)]
912 ["Revert to Non-MIME Edit (MH)"
913 mh-mh-to-mime-undo
(equal mh-compose-insertion
'mh
)]
914 ["Kill This Draft" mh-fully-kill-draft t
]))
920 ;; Group messages logically, more or less.
921 (defvar mh-letter-mode-help-messages
923 "Send letter: \\[mh-send-letter]"
924 "\t\tOpen line: \\[mh-open-line]\n"
925 "Kill letter: \\[mh-fully-kill-draft]"
927 "Check recipients: \\[mh-check-whom]"
928 "\t\t Current message: \\[mh-yank-cur-msg]\n"
929 "\t\t Attachment: \\[mh-compose-insertion]\n"
930 "\t\t Message to forward: \\[mh-compose-forward]\n"
933 "\t\t Encrypt message: \\[mh-mml-secure-message-encrypt]"
934 "\t\t Sign+Encrypt message: \\[mh-mml-secure-message-signencrypt]"
935 "\t\t Sign message: \\[mh-mml-secure-message-sign]\n"
937 "\t\t Signature: \\[mh-insert-signature]"))
938 "Key binding cheat sheet.
940 This is an associative array which is used to show the most
941 common commands. The key is a prefix char. The value is one or
942 more strings which are concatenated together and displayed in the
943 minibuffer if ? is pressed after the prefix character. The
944 special key nil is used to display the non-prefixed commands.
946 The substitutions described in `substitute-command-keys' are
950 (defun mh-fill-paragraph-function (arg)
951 "Fill paragraph at or after point.
952 Prefix ARG means justify as well. This function enables
953 `fill-paragraph' to work better in MH-Letter mode (see
956 (let ((fill-paragraph-function) (fill-prefix))
958 (mail-mode-fill-paragraph arg
)
959 (fill-paragraph arg
))))
961 ;; Avoid compiler warnings in XEmacs and Emacs 20
963 (defvar tool-bar-mode
)
964 (defvar tool-bar-map
))
966 (defvar mh-letter-buttons-init-flag nil
)
969 (define-derived-mode mh-letter-mode text-mode
"MH-Letter"
970 "Mode for composing letters in MH-E\\<mh-letter-mode-map>.
972 When you have finished composing, type \\[mh-send-letter] to send
973 the message using the MH mail handling system.
975 There are two types of tags used by MH-E when composing MIME
976 messages: MML and MH. The option `mh-compose-insertion' controls
977 what type of tags are inserted by MH-E commands. These tags can
978 be converted to MIME body parts by running \\[mh-mh-to-mime] for
979 MH-style directives or \\[mh-mml-to-mime] for MML tags.
981 Options that control this mode can be changed with
982 \\[customize-group]; specify the \"mh-compose\" group.
984 When a message is composed, the hooks `text-mode-hook' and
985 `mh-letter-mode-hook' are run.
987 \\{mh-letter-mode-map}"
989 (make-local-variable 'mh-send-args
)
990 (make-local-variable 'mh-annotate-char
)
991 (make-local-variable 'mh-annotate-field
)
992 (make-local-variable 'mh-previous-window-config
)
993 (make-local-variable 'mh-sent-from-folder
)
994 (make-local-variable 'mh-sent-from-msg
)
996 (unless mh-letter-buttons-init-flag
997 (mh-tool-bar-letter-buttons-init)
998 (setq mh-letter-buttons-init-flag t
)))
999 ;; Set the local value of mh-mail-header-separator according to what is
1000 ;; present in the buffer...
1001 (set (make-local-variable 'mh-mail-header-separator
)
1003 (goto-char (mh-mail-header-end))
1004 (buffer-substring-no-properties (point) (line-end-position))))
1005 (make-local-variable 'mail-header-separator
)
1006 (setq mail-header-separator mh-mail-header-separator
) ;override sendmail.el
1007 (make-local-variable 'mh-help-messages
)
1008 (setq mh-help-messages mh-letter-mode-help-messages
)
1009 (setq buffer-invisibility-spec
'((vanish . t
) t
))
1010 (set (make-local-variable 'line-move-ignore-invisible
) t
)
1012 ;; From sendmail.el for proper paragraph fill
1013 ;; sendmail.el also sets a normal-auto-fill-function (not done here)
1014 (make-local-variable 'paragraph-separate
)
1015 (make-local-variable 'paragraph-start
)
1016 (make-local-variable 'fill-paragraph-function
)
1017 (setq fill-paragraph-function
'mh-fill-paragraph-function
)
1018 (make-local-variable 'adaptive-fill-regexp
)
1019 (setq adaptive-fill-regexp
1020 (concat adaptive-fill-regexp
1021 "\\|[ \t]*[-[:alnum:]]*>+[ \t]*"))
1022 (make-local-variable 'adaptive-fill-first-line-regexp
)
1023 (setq adaptive-fill-first-line-regexp
1024 (concat adaptive-fill-first-line-regexp
1025 "\\|[ \t]*[-[:alnum:]]*>+[ \t]*"))
1026 ;; `-- ' precedes the signature. `-----' appears at the start of the
1027 ;; lines that delimit forwarded messages.
1028 ;; Lines containing just >= 3 dashes, perhaps after whitespace,
1029 ;; are also sometimes used and should be separators.
1030 (setq paragraph-start
(concat (regexp-quote mail-header-separator
)
1031 "\\|\t*\\([-|#;>* ]\\|(?[0-9]+[.)]\\)+$"
1032 "\\|[ \t]*[[:alnum:]]*>+[ \t]*$\\|[ \t]*$\\|"
1035 (setq paragraph-separate paragraph-start
)
1036 ;; --- End of code from sendmail.el ---
1038 ;; Enable undo since a show-mode buffer might have been reused.
1039 (buffer-enable-undo)
1040 (set (make-local-variable 'tool-bar-map
) mh-letter-tool-bar-map
)
1041 (mh-funcall-if-exists mh-tool-bar-init
:letter
)
1042 (make-local-variable 'font-lock-defaults
)
1044 ((or (equal mh-highlight-citation-style
'font-lock
)
1045 (equal mh-highlight-citation-style
'gnus
))
1046 ;; Let's use font-lock even if gnus is used in show-mode. The reason
1047 ;; is that gnus uses static text properties which are not appropriate
1048 ;; for a buffer that will be edited. So the choice here is either fontify
1049 ;; the citations and header...
1050 (setq font-lock-defaults
'(mh-letter-font-lock-keywords t
)))
1052 ;; ...or the header only
1053 (setq font-lock-defaults
'(mh-show-font-lock-keywords t
))))
1054 (easy-menu-add mh-letter-menu
)
1055 (setq fill-column mh-letter-fill-column
)
1056 ;; If text-mode-hook turned on auto-fill, tune it for messages
1057 (when auto-fill-function
1058 (make-local-variable 'auto-fill-function
)
1059 (setq auto-fill-function
'mh-auto-fill-for-letter
)))
1061 (defun mh-font-lock-field-data (limit)
1062 "Find header field region between point and LIMIT."
1063 (and (< (point) (mh-letter-header-end))
1065 (let ((end (min limit
(mh-letter-header-end)))
1067 data-end data-begin field
)
1069 (setq data-end
(if (re-search-forward "^[^ \t]" end t
)
1072 (goto-char (1- data-end
))
1073 (if (not (re-search-backward "\\(^[^ \t][^:]*\\):[ \t]*" nil t
))
1074 (setq data-begin
(point-min))
1075 (setq data-begin
(match-end 0))
1076 (setq field
(match-string 1)))
1077 (setq data-begin
(max point data-begin
))
1078 (goto-char (if (equal point data-end
) (1+ data-end
) data-end
))
1079 (cond ((and field
(mh-letter-skipped-header-field-p field
))
1080 (set-match-data nil
)
1083 (list data-begin data-end data-begin data-end
))
1086 (defun mh-letter-header-end ()
1087 "Find the end of the message header.
1088 This function is to be used only for font locking. It works by
1089 searching for `mh-mail-header-separator' in the buffer."
1091 (goto-char (point-min))
1092 (cond ((equal mh-mail-header-separator
"") (point-min))
1093 ((search-forward (format "\n%s\n" mh-mail-header-separator
) nil t
)
1094 (line-beginning-position 0))
1097 (defun mh-auto-fill-for-letter ()
1098 "Perform auto-fill for message.
1099 Header is treated specially by inserting a tab before continuation
1101 (if (mh-in-header-p)
1102 (let ((fill-prefix "\t"))
1106 (defun mh-insert-header-separator ()
1107 "Insert `mh-mail-header-separator', if absent."
1109 (goto-char (point-min))
1111 (if (looking-at "$")
1112 (insert mh-mail-header-separator
))))
1115 (defun mh-to-field ()
1116 "Move to specified header field.
1117 The field is indicated by the previous keystroke (the last keystroke
1118 of the command) according to the list in the variable
1119 `mh-to-field-choices'. Create the field if it does not exist. Set the
1120 mark to point before moving."
1123 (let ((target (cdr (or (assoc (char-to-string (logior last-input-char ?
`))
1124 mh-to-field-choices
)
1125 ;; also look for a char for version 4 compat
1126 (assoc (logior last-input-char ?
`)
1127 mh-to-field-choices
))))
1128 (case-fold-search t
))
1130 (cond ((mh-position-on-field target
)
1131 (let ((eol (point)))
1132 (skip-chars-backward " \t")
1133 (delete-region (point) eol
))
1134 (if (and (not (eq (logior last-input-char ?
`) ?s
))
1137 (not (looking-at "[:,]"))))
1141 (if (mh-position-on-field "To:")
1143 (insert (format "%s \n" target
))
1144 (backward-char 1)))))
1147 (defun mh-to-fcc (&optional folder
)
1148 "Move to \"Fcc:\" header field.
1149 This command will prompt you for the FOLDER name in which to file a
1153 (setq folder
(mh-prompt-for-folder
1155 (or (and mh-default-folder-for-message-function
1157 (goto-char (point-min))
1159 mh-default-folder-for-message-function
)))
1162 (let ((last-input-char ?\C-f
))
1166 (insert (if (mh-folder-name-p folder
)
1167 (substring folder
1)
1170 (defun mh-file-is-vcard-p (file)
1171 "Return t if FILE is a .vcf vcard."
1172 (let ((case-fold-search t
))
1174 (file-exists-p file
)
1175 (or (and (not (mh-have-file-command))
1176 (not (null (string-match "\.vcf$" file
))))
1177 (and (mh-have-file-command)
1178 (string-equal "text/x-vcard" (mh-file-mime-type file
)))))))
1181 (defun mh-insert-signature (&optional file
)
1182 "Insert signature in message.
1184 This command inserts your signature at the current cursor location.
1186 By default, the text of your signature is taken from the file
1187 \"~/.signature\". You can read from other sources by changing the
1188 option `mh-signature-file-name'.
1190 A signature separator (\"-- \") will be added if the signature block
1191 does not contain one and `mh-signature-separator-flag' is on.
1193 The hook `mh-insert-signature-hook' is run after the signature is
1194 inserted. Hook functions may access the actual name of the file or the
1195 function used to insert the signature with `mh-signature-file-name'.
1197 The signature can also be inserted using Identities (see
1198 `mh-identity-list').
1200 In a program, you can pass in a signature FILE."
1204 (let ((mh-signature-file-name (or file mh-signature-file-name
))
1205 (mh-mh-p (mh-mh-directive-present-p))
1206 (mh-mml-p (mh-mml-tag-present-p)))
1208 (narrow-to-region (point) (point))
1210 ((mh-file-is-vcard-p mh-signature-file-name
)
1211 (if (equal mh-compose-insertion
'mml
)
1212 (insert "<#part type=\"text/x-vcard\" filename=\""
1213 mh-signature-file-name
1214 "\" disposition=inline description=VCard>\n<#/part>")
1215 (insert "#text/x-vcard; name=\""
1216 (file-name-nondirectory mh-signature-file-name
)
1217 "\" [VCard] " (expand-file-name mh-signature-file-name
))))
1221 (insert "#\n" "Content-Description: Signature\n"))
1223 (mml-insert-tag 'part
'type
"text/plain" 'disposition
"inline"
1224 'description
"Signature")))
1225 (cond ((null mh-signature-file-name
))
1226 ((and (stringp mh-signature-file-name
)
1227 (file-readable-p mh-signature-file-name
))
1228 (insert-file-contents mh-signature-file-name
))
1229 ((functionp mh-signature-file-name
)
1230 (funcall mh-signature-file-name
)))))
1233 (run-hooks 'mh-insert-signature-hook
))
1234 (goto-char (point-min))
1235 (when (and (not (mh-file-is-vcard-p mh-signature-file-name
))
1236 mh-signature-separator-flag
1237 (> (point-max) (point-min))
1238 (not (mh-signature-separator-p)))
1243 (insert mh-signature-separator
))
1244 (if (not (> (point-max) (point-min)))
1245 (message "No signature found")))))
1246 (force-mode-line-update))
1249 (defun mh-check-whom ()
1250 "Verify recipients, showing expansion of any aliases.
1252 This command expands aliases so you can check the actual address(es)
1253 in the alias. A new buffer named \"*MH-E Recipients*\" is created with
1254 the output of \"whom\"."
1256 (let ((file-name buffer-file-name
))
1258 (message "Checking recipients...")
1259 (mh-in-show-buffer (mh-recipients-buffer)
1260 (bury-buffer (current-buffer))
1262 (mh-exec-cmd-output "whom" t file-name
))
1263 (message "Checking recipients...done")))
1265 (defun mh-tidy-draft-buffer ()
1266 "Run when a draft buffer is destroyed."
1267 (let ((buffer (get-buffer mh-recipients-buffer
)))
1269 (kill-buffer buffer
))))
1273 ;;; Routines to compose and send a letter.
1275 (defun mh-insert-x-face ()
1276 "Append X-Face, Face or X-Image-URL field to header.
1277 If the field already exists, this function does nothing."
1278 (when (and (file-exists-p mh-x-face-file
)
1279 (file-readable-p mh-x-face-file
))
1281 (unless (or (mh-position-on-field "X-Face")
1282 (mh-position-on-field "Face")
1283 (mh-position-on-field "X-Image-URL"))
1285 (goto-char (+ (point) (cadr (insert-file-contents mh-x-face-file
))))
1286 (if (not (looking-at "^"))
1288 (unless (looking-at "\\(X-Face\\|Face\\|X-Image-URL\\): ")
1289 (insert "X-Face: "))))))
1291 (defvar mh-x-mailer-string nil
1292 "*String containing the contents of the X-Mailer header field.
1293 If nil, this variable is initialized to show the version of MH-E,
1294 Emacs, and MH the first time a message is composed.")
1296 (defun mh-insert-x-mailer ()
1297 "Append an X-Mailer field to the header.
1298 The versions of MH-E, Emacs, and MH are shown."
1299 ;; Lazily initialize mh-x-mailer-string.
1300 (when (and mh-insert-x-mailer-flag
(null mh-x-mailer-string
))
1301 (setq mh-x-mailer-string
1302 (format "MH-E %s; %s; %sEmacs %s"
1303 mh-version mh-variant-in-use
1304 (if mh-xemacs-flag
"X" "GNU ")
1305 (cond ((not mh-xemacs-flag
) emacs-version
)
1306 ((string-match "[0-9.]*\\( +\([ a-z]+[0-9]+\)\\)?"
1308 (match-string 0 emacs-version
))
1309 (t (format "%s.%s" emacs-major-version
1310 emacs-minor-version
))))))
1311 ;; Insert X-Mailer, but only if it doesn't already exist.
1313 (when (and mh-insert-x-mailer-flag
1314 (null (mh-goto-header-field "X-Mailer")))
1315 (mh-insert-fields "X-Mailer:" mh-x-mailer-string
))))
1317 (defun mh-regexp-in-field-p (regexp &rest fields
)
1318 "Non-nil means REGEXP was found in FIELDS."
1320 (let ((search-result nil
)
1323 (setq field
(car fields
))
1324 (if (and (mh-goto-header-field field
)
1326 regexp
(save-excursion (mh-header-field-end)(point)) t
))
1329 (setq fields
(cdr fields
))))
1333 (defun mh-insert-auto-fields (&optional non-interactive
)
1334 "Insert custom fields if recipient is found in `mh-auto-fields-list'.
1336 Sets buffer-local `mh-insert-auto-fields-done-local' when done
1337 and inserted something. If NON-INTERACTIVE is non-nil, do not be
1338 verbose and only attempt matches if
1339 `mh-insert-auto-fields-done-local' is nil.
1341 An `identity' entry is skipped if one was already entered
1344 Return t if fields added; otherwise return nil."
1346 (when (or (not non-interactive
)
1347 (not mh-insert-auto-fields-done-local
))
1349 (when (and (or (mh-goto-header-field "To:")
1350 (mh-goto-header-field "cc:")))
1351 (let ((list mh-auto-fields-list
)
1352 (fields-inserted nil
))
1354 (let ((regexp (nth 0 (car list
)))
1355 (entries (nth 1 (car list
))))
1356 (when (mh-regexp-in-field-p regexp
"To:" "cc:")
1357 (setq mh-insert-auto-fields-done-local t
)
1358 (setq fields-inserted t
)
1359 (if (not non-interactive
)
1360 (message "Fields for %s added" regexp
))
1361 (let ((entry-list entries
))
1363 (let ((field (caar entry-list
))
1364 (value (cdar entry-list
)))
1366 ((equal ":identity" field
)
1367 (when ;;(and (not mh-identity-local)
1368 ;; Bug 1204506. But do we need to be able
1369 ;; to set an identity manually that won't be
1370 ;; overridden by mh-insert-auto-fields?
1371 (assoc value mh-identity-list
)
1373 (mh-insert-identity value
)))
1375 (mh-modify-header-field field value
1376 (equal field
"From")))))
1377 (setq entry-list
(cdr entry-list
))))))
1378 (setq list
(cdr list
)))
1379 fields-inserted
)))))
1381 (defun mh-modify-header-field (field value
&optional overwrite-flag
)
1382 "To header FIELD add VALUE.
1383 If OVERWRITE-FLAG is non-nil then the old value, if present, is
1385 (cond ((and overwrite-flag
1386 (mh-goto-header-field (concat field
":")))
1388 (delete-region (point) (line-end-position)))
1389 ((and (not overwrite-flag
)
1390 (mh-regexp-in-field-p (concat "\\b" value
"\\b") field
))
1391 ;; Already there, do nothing.
1393 ((and (not overwrite-flag
)
1394 (mh-goto-header-field (concat field
":")))
1395 (insert " " value
","))
1397 (mh-goto-header-end 0)
1398 (insert field
": " value
"\n"))))
1400 (defun mh-compose-and-send-mail (draft send-args
1401 sent-from-folder sent-from-msg
1403 annotate-char annotate-field
1405 "Edit and compose a draft message in buffer DRAFT and send or save it.
1406 SEND-ARGS is the argument passed to the send command.
1407 SENT-FROM-FOLDER is buffer containing scan listing of current folder,
1408 or nil if none exists.
1409 SENT-FROM-MSG is the message number or sequence name or nil.
1410 The TO, SUBJECT, and CC fields are passed to the
1411 `mh-compose-letter-function'.
1412 If ANNOTATE-CHAR is non-null, it is used to notate the scan listing of
1413 the message. In that case, the ANNOTATE-FIELD is used to build a
1414 string for `mh-annotate-msg'.
1415 CONFIG is the window configuration to restore after sending the
1417 (pop-to-buffer draft
)
1421 (if (and (boundp 'mh-identity-default
)
1423 (not mh-identity-local
))
1424 (mh-insert-identity mh-identity-default
))
1425 (mh-identity-make-menu)
1426 (easy-menu-add mh-identity-menu
)
1428 ;; Insert extra fields.
1429 (mh-insert-x-mailer)
1432 (mh-letter-hide-all-skipped-fields)
1434 (setq mh-sent-from-folder sent-from-folder
)
1435 (setq mh-sent-from-msg sent-from-msg
)
1436 (setq mh-send-args send-args
)
1437 (setq mh-annotate-char annotate-char
)
1438 (setq mh-annotate-field annotate-field
)
1439 (setq mh-previous-window-config config
)
1440 (setq mode-line-buffer-identification
(list " {%b}"))
1442 (mh-make-local-hook 'kill-buffer-hook
)
1443 (add-hook 'kill-buffer-hook
'mh-tidy-draft-buffer nil t
)
1444 (if (and (boundp 'mh-compose-letter-function
)
1445 mh-compose-letter-function
)
1446 ;; run-hooks will not pass arguments.
1447 (let ((value mh-compose-letter-function
))
1448 (if (and (listp value
) (not (eq (car value
) 'lambda
)))
1450 (funcall (car value
) to subject cc
)
1451 (setq value
(cdr value
)))
1452 (funcall mh-compose-letter-function to subject cc
)))))
1454 (defun mh-letter-mode-message ()
1455 "Display a help message for users of `mh-letter-mode'.
1456 This should be the last function called when composing the draft."
1457 (message "%s" (substitute-command-keys
1458 (concat "Type \\[mh-send-letter] to send message, "
1459 "\\[mh-help] for help"))))
1461 (defun mh-ascii-buffer-p ()
1462 "Check if current buffer is entirely composed of ASCII.
1463 The function doesn't work for XEmacs since `find-charset-region'
1464 doesn't exist there."
1465 (loop for charset in
(mh-funcall-if-exists
1466 find-charset-region
(point-min) (point-max))
1467 unless
(eq charset
'ascii
) return nil
1471 (defun mh-send-letter (&optional arg
)
1472 "Save draft and send message.
1474 When you are all through editing a message, you send it with this
1475 command. You can give a prefix argument ARG to monitor the first stage
1476 of the delivery\; this output can be found in a buffer called \"*MH-E
1479 The hook `mh-before-send-letter-hook' is run at the beginning of the
1480 this command. For example, if you want to check your spelling in your
1481 message before sending, add the `ispell-message' function.
1483 In case the MH \"send\" program is installed under a different name,
1484 use `mh-send-prog' to tell MH-E the name."
1486 (run-hooks 'mh-before-send-letter-hook
)
1487 (if (and (mh-insert-auto-fields t
)
1488 mh-auto-fields-prompt-flag
1489 (goto-char (point-min)))
1490 (if (not (y-or-n-p "Auto fields inserted, send? "))
1491 (error "Send aborted")))
1492 (cond ((mh-mh-directive-present-p)
1494 ((or (mh-mml-tag-present-p) (not (mh-ascii-buffer-p)))
1497 (message "Sending...")
1498 (let ((draft-buffer (current-buffer))
1499 (file-name buffer-file-name
)
1500 (config mh-previous-window-config
)
1501 (coding-system-for-write
1502 (if (and (local-variable-p 'buffer-file-coding-system
1503 (current-buffer)) ;XEmacs needs two args
1504 ;; We're not sure why, but buffer-file-coding-system
1505 ;; tends to get set to undecided-unix.
1506 (not (memq buffer-file-coding-system
1507 '(undecided undecided-unix undecided-dos
))))
1508 buffer-file-coding-system
1509 (or (and (boundp 'sendmail-coding-system
) sendmail-coding-system
)
1510 (and (boundp 'default-buffer-file-coding-system
)
1511 default-buffer-file-coding-system
)
1513 ;; The default BCC encapsulation will make a MIME message unreadable.
1514 ;; With nmh use the -mime arg to prevent this.
1515 (if (and (mh-variant-p 'nmh
)
1516 (mh-goto-header-field "Bcc:")
1517 (mh-goto-header-field "Content-Type:"))
1518 (setq mh-send-args
(format "-mime %s" mh-send-args
)))
1520 (pop-to-buffer mh-mail-delivery-buffer
)
1522 (mh-exec-cmd-output mh-send-prog t
"-watch" "-nopush"
1523 "-nodraftfolder" mh-send-args file-name
)
1524 (goto-char (point-max)) ; show the interesting part
1526 (set-buffer draft-buffer
)) ; for annotation below
1528 (mh-exec-cmd-daemon mh-send-prog nil
"-nodraftfolder" "-noverbose"
1529 mh-send-args file-name
)))
1530 (if mh-annotate-char
1531 (mh-annotate-msg mh-sent-from-msg
1534 "-component" mh-annotate-field
1535 "-text" (format "\"%s %s\""
1536 (mh-get-header-field "To:")
1537 (mh-get-header-field "Cc:"))))
1539 (cond ((or (not arg
)
1540 (y-or-n-p "Kill draft buffer? "))
1541 (kill-buffer draft-buffer
)
1543 (set-window-configuration config
))))
1545 (message "Sending...done")
1546 (message "Sending...backgrounded"))))
1549 (defun mh-insert-letter (folder message verbatim
)
1552 This command prompts you for the FOLDER and MESSAGE number and inserts
1553 the message, indented by `mh-ins-buf-prefix' (\"> \") unless
1554 `mh-yank-behavior' is set to one of the supercite flavors in which
1555 case supercite is used to format the message. Certain undesirable
1556 header fields (see `mh-invisible-header-fields-compiled') are removed
1559 If given a prefix argument VERBATIM, the header is left intact, the
1560 message is not indented, and \"> \" is not inserted before each line.
1561 This command leaves the mark before the letter and point after it."
1563 (list (mh-prompt-for-folder "Message from" mh-sent-from-folder nil
)
1564 (read-string (concat "Message number"
1565 (if (numberp mh-sent-from-msg
)
1566 (format " (default %d): " mh-sent-from-msg
)
1568 current-prefix-arg
))
1570 (narrow-to-region (point) (point))
1571 (let ((start (point-min)))
1572 (if (and (equal message
"") (numberp mh-sent-from-msg
))
1573 (setq message
(int-to-string mh-sent-from-msg
)))
1574 (insert-file-contents
1575 (expand-file-name message
(mh-expand-file-name folder
)))
1576 (when (not verbatim
)
1577 (mh-clean-msg-header start mh-invisible-header-fields-compiled nil
)
1578 (goto-char (point-max)) ;Needed for sc-cite-original
1579 (push-mark) ;Needed for sc-cite-original
1580 (goto-char (point-min)) ;Needed for sc-cite-original
1581 (mh-insert-prefix-string mh-ins-buf-prefix
)))))
1583 (defun mh-extract-from-attribution ()
1584 "Extract phrase or comment from From header field."
1586 (if (not (mh-goto-header-field "From: "))
1588 (skip-chars-forward " ")
1590 ((looking-at "\"\\([^\"\n]+\\)\" \\(<.+>\\)")
1591 (format "%s %s " (match-string 1)(match-string 2)))
1592 ((looking-at "\\([^<\n]+<.+>\\)$")
1593 (format "%s " (match-string 1)))
1594 ((looking-at "\\([^ ]+@[^ ]+\\) +(\\(.+\\))$")
1595 (format "%s <%s> " (match-string 2)(match-string 1)))
1596 ((looking-at " *\\(.+\\)$")
1597 (format "%s " (match-string 1)))))))
1600 (defun mh-yank-cur-msg ()
1601 "Insert the current message into the draft buffer.
1603 It is often useful to insert a snippet of text from a letter that
1604 someone mailed to provide some context for your reply. This
1605 command does this by adding an attribution, yanking a portion of
1606 text from the message to which you're replying, and inserting
1607 `mh-ins-buf-prefix' (`> ') before each line.
1609 The attribution consists of the sender's name and email address
1610 followed by the content of the `mh-extract-from-attribution-verb'
1613 You can also turn on the `mh-delete-yanked-msg-window-flag'
1614 option to delete the window containing the original message after
1615 yanking it to make more room on your screen for your reply.
1617 You can control how the message to which you are replying is
1618 yanked into your reply using `mh-yank-behavior'.
1620 If this isn't enough, you can gain full control over the
1621 appearance of the included text by setting `mail-citation-hook'
1622 to a function that modifies it. For example, if you set this hook
1623 to `trivial-cite' (which is NOT part of Emacs), set
1624 `mh-yank-behavior' to \"Body and Header\" (see URL
1625 `http://shasta.cs.uiuc.edu/~lrclause/tc.html').
1627 Note that if `mail-citation-hook' is set, `mh-ins-buf-prefix' is
1628 not inserted. If the option `mh-yank-behavior' is set to one of
1629 the supercite flavors, the hook `mail-citation-hook' is ignored
1630 and `mh-ins-buf-prefix' is not inserted."
1632 (if (and mh-sent-from-folder
1633 (save-excursion (set-buffer mh-sent-from-folder
) mh-show-buffer
)
1634 (save-excursion (set-buffer mh-sent-from-folder
)
1635 (get-buffer mh-show-buffer
))
1637 (let ((to-point (point))
1638 (to-buffer (current-buffer)))
1639 (set-buffer mh-sent-from-folder
)
1640 (if mh-delete-yanked-msg-window-flag
1641 (delete-windows-on mh-show-buffer
))
1642 (set-buffer mh-show-buffer
) ; Find displayed message
1643 (let* ((from-attr (mh-extract-from-attribution))
1644 (yank-region (mh-mark-active-p nil
))
1646 (cond ((and yank-region
1647 (or (eq 'supercite mh-yank-behavior
)
1648 (eq 'autosupercite mh-yank-behavior
)
1649 (eq t mh-yank-behavior
)))
1650 ;; supercite needs the full header
1652 (buffer-substring (point-min) (mh-mail-header-end))
1654 (buffer-substring (region-beginning) (region-end))))
1656 (buffer-substring (region-beginning) (region-end)))
1657 ((or (eq 'body mh-yank-behavior
)
1658 (eq 'attribution mh-yank-behavior
)
1659 (eq 'autoattrib mh-yank-behavior
))
1662 (goto-char (point-min))
1663 (mh-goto-header-end 1)
1666 ((or (eq 'supercite mh-yank-behavior
)
1667 (eq 'autosupercite mh-yank-behavior
)
1668 (eq t mh-yank-behavior
))
1669 (buffer-substring (point-min) (point-max)))
1671 (buffer-substring (point) (point-max))))))
1672 (set-buffer to-buffer
)
1674 (narrow-to-region to-point to-point
)
1675 (insert (mh-filter-out-non-text mh-ins-str
))
1676 (goto-char (point-max)) ;Needed for sc-cite-original
1677 (push-mark) ;Needed for sc-cite-original
1678 (goto-char (point-min)) ;Needed for sc-cite-original
1679 (mh-insert-prefix-string mh-ins-buf-prefix
)
1680 (when (or (eq 'attribution mh-yank-behavior
)
1681 (eq 'autoattrib mh-yank-behavior
))
1683 (mh-identity-insert-attribution-verb nil
)
1685 ;; If the user has selected a region, he has already "edited" the
1686 ;; text, so leave the cursor at the end of the yanked text. In
1687 ;; either case, leave a mark at the opposite end of the included
1688 ;; text to make it easy to jump or delete to the other end of the
1691 (goto-char (point-max))
1692 (if (null yank-region
)
1693 (mh-exchange-point-and-mark-preserving-active-mark)))))
1694 (error "There is no current message")))
1696 (defun mh-filter-out-non-text (string)
1697 "Return STRING but without adornments such as MIME buttons and smileys."
1699 ;; Insert the string to filter
1701 (goto-char (point-min))
1703 ;; Remove the MIME buttons
1704 (let ((can-move-forward t
)
1706 (while can-move-forward
1707 (cond ((and (not (get-text-property (point) 'mh-data
))
1709 (delete-region (1- (point)) (point))
1710 (setq in-button nil
))
1711 ((get-text-property (point) 'mh-data
)
1712 (delete-region (point)
1713 (save-excursion (forward-line) (point)))
1715 (t (setq can-move-forward
(= (forward-line) 0))))))
1717 ;; Return the contents without properties... This gets rid of emphasis
1719 (buffer-substring-no-properties (point-min) (point-max))))
1721 (defun mh-insert-prefix-string (mh-ins-string)
1722 "Insert prefix string before each line in buffer.
1723 The inserted letter is cited using `sc-cite-original' if
1724 `mh-yank-behavior' is one of 'supercite or 'autosupercite.
1725 Otherwise, simply insert MH-INS-STRING before each line."
1726 (goto-char (point-min))
1727 (cond ((or (eq mh-yank-behavior
'supercite
)
1728 (eq mh-yank-behavior
'autosupercite
))
1731 (run-hooks 'mail-citation-hook
))
1732 (mh-yank-hooks ;old hook name
1733 (run-hooks 'mh-yank-hooks
))
1735 (or (bolp) (forward-line 1))
1736 (while (< (point) (point-max))
1737 (insert mh-ins-string
)
1739 (goto-char (point-min))))) ;leave point like sc-cite-original
1742 (defun mh-fully-kill-draft ()
1743 "Quit editing and delete draft message.
1744 If for some reason you are not happy with the draft, you can use
1745 the this command to kill the draft buffer and delete the draft
1746 message. Use the \\[kill-buffer] command if you don't want to
1747 delete the draft message."
1749 (if (y-or-n-p "Kill draft message? ")
1750 (let ((config mh-previous-window-config
))
1751 (if (file-exists-p buffer-file-name
)
1752 (delete-file buffer-file-name
))
1753 (set-buffer-modified-p nil
)
1754 (kill-buffer (buffer-name))
1757 (set-window-configuration config
)))
1758 (error "Message not killed")))
1760 (defun mh-current-fill-prefix ()
1761 "Return the `fill-prefix' on the current line as a string."
1764 ;; This assumes that the major-mode sets up adaptive-fill-regexp
1765 ;; correctly such as mh-letter-mode or sendmail.el's mail-mode. But
1766 ;; perhaps I should use the variable and simply inserts its value here,
1767 ;; and set it locally in a let scope. --psg
1768 (if (re-search-forward adaptive-fill-regexp nil t
)
1773 (defun mh-open-line ()
1774 "Insert a newline and leave point after it.
1776 This command is similar to the \\[open-line] command in that it
1777 inserts a newline after point. It differs in that it also inserts
1778 the right number of quoting characters and spaces so that the
1779 next line begins in the same column as it was. This is useful
1780 when breaking up paragraphs in replies."
1782 (let ((column (current-column))
1783 (prefix (mh-current-fill-prefix)))
1784 (if (> (length prefix
) column
)
1785 (message "Sorry, point seems to be within the line prefix")
1788 (while (> column
(current-column))
1790 (forward-line -
1))))
1792 (mh-do-in-xemacs (defvar mail-abbrevs
))
1794 (defmacro mh-display-completion-list-compat
(word choices
)
1795 "Completes WORD from CHOICES using `display-completion-list'.
1796 Calls `display-completion-list' correctly in older environments.
1797 Versions of Emacs prior to version 22 lacked a COMMON-SUBSTRING
1798 argument which is used to highlight the next possible character you
1799 can enter in the current list of completions."
1800 (if (>= emacs-major-version
22)
1801 `(display-completion-list (all-completions ,word
,choices
) ,word
)
1802 `(display-completion-list (all-completions ,word
,choices
))))
1805 (defun mh-complete-word (word choices begin end
)
1806 "Complete WORD at from CHOICES.
1807 Any match found replaces the text from BEGIN to END."
1808 (let ((completion (try-completion word choices
))
1809 (completions-buffer "*Completions*"))
1810 (cond ((eq completion t
)
1812 (kill-buffer completions-buffer
))
1813 (message "Completed: %s" word
))
1816 (kill-buffer completions-buffer
))
1817 (message "No completion for `%s'" word
))
1818 ((stringp completion
)
1819 (if (equal word completion
)
1820 (with-output-to-temp-buffer completions-buffer
1821 (mh-display-completion-list-compat word choices
))
1823 (kill-buffer completions-buffer
))
1824 (delete-region begin end
)
1825 (insert completion
))))))
1828 (defun mh-beginning-of-word (&optional n
)
1829 "Return position of the N th word backwards."
1830 (unless n
(setq n
1))
1831 (let ((syntax-table (syntax-table)))
1834 (mh-mail-abbrev-make-syntax-table)
1835 (set-syntax-table mail-abbrev-syntax-table
)
1838 (set-syntax-table syntax-table
))))
1840 (defun mh-folder-expand-at-point ()
1841 "Do folder name completion in Fcc header field."
1842 (let* ((end (point))
1843 (beg (mh-beginning-of-word))
1844 (folder (buffer-substring beg end
))
1845 (leading-plus (and (> (length folder
) 0) (equal (aref folder
0) ?
+)))
1846 (last-slash (mh-search-from-end ?
/ folder
))
1847 (prefix (and last-slash
(substring folder
0 last-slash
)))
1848 (choices (mapcar #'(lambda (x)
1849 (list (cond (prefix (format "%s/%s" prefix x
))
1850 (leading-plus (format "+%s" x
))
1852 (mh-folder-completion-function folder nil t
))))
1853 (mh-complete-word folder choices beg end
)))
1855 (defvar mh-letter-complete-function-alist
1856 '((cc . mh-alias-letter-expand-alias
)
1857 (bcc . mh-alias-letter-expand-alias
)
1858 (dcc . mh-alias-letter-expand-alias
)
1859 (fcc . mh-folder-expand-at-point
)
1860 (from . mh-alias-letter-expand-alias
)
1861 (mail-followup-to . mh-alias-letter-expand-alias
)
1862 (reply-to . mh-alias-letter-expand-alias
)
1863 (to . mh-alias-letter-expand-alias
))
1864 "Alist of header fields and completion functions to use.")
1866 (defun mh-letter-complete (arg)
1867 "Perform completion on header field or word preceding point.
1868 If the field contains addresses (for example, \"To:\" or \"Cc:\")
1869 or folders (for example, \"Fcc:\") then this command will
1870 provide alias completion. In the body of the message, this
1871 command runs `mh-letter-complete-function' instead, which is set
1872 to \"'ispell-complete-word\" by default. This command takes a
1873 prefix argument ARG that is passed to the
1874 `mh-letter-complete-function'."
1877 (cond ((not (mh-in-header-p))
1878 (funcall mh-letter-complete-function arg
))
1879 ((setq func
(cdr (assoc (mh-letter-header-field-at-point)
1880 mh-letter-complete-function-alist
)))
1882 (t (funcall mh-letter-complete-function arg
)))))
1884 (defun mh-letter-complete-or-space (arg)
1885 "Perform completion or insert space.
1886 Turn on the `mh-compose-space-does-completion-flag' option to use
1887 this command to perform completion in the header. Otherwise, a
1890 ARG is the number of spaces inserted."
1893 (end-of-prev (save-excursion
1894 (goto-char (mh-beginning-of-word))
1895 (mh-beginning-of-word -
1))))
1896 (cond ((not mh-compose-space-does-completion-flag
)
1897 (self-insert-command arg
))
1898 ((not (mh-in-header-p)) (self-insert-command arg
))
1899 ((> (point) end-of-prev
) (self-insert-command arg
))
1900 ((setq func
(cdr (assoc (mh-letter-header-field-at-point)
1901 mh-letter-complete-function-alist
)))
1903 (t (self-insert-command arg
)))))
1905 (defun mh-letter-confirm-address ()
1906 "Flash alias expansion.
1907 Addresses are separated by a comma\; and when you press the
1908 comma, this command flashes the alias expansion in the minibuffer
1909 if `mh-alias-flash-on-comma' is turned on."
1911 (cond ((not (mh-in-header-p)) (self-insert-command 1))
1912 ((eq (cdr (assoc (mh-letter-header-field-at-point)
1913 mh-letter-complete-function-alist
))
1914 'mh-alias-letter-expand-alias
)
1915 (mh-alias-reload-maybe)
1916 (mh-alias-minibuffer-confirm-address))
1917 (t (self-insert-command 1))))
1919 (defvar mh-letter-header-field-regexp
"^\\([A-Za-z][A-Za-z0-9-]*\\):")
1921 (defun mh-letter-header-field-at-point ()
1922 "Return the header field name at point.
1923 A symbol is returned whose name is the string obtained by
1924 downcasing the field name."
1927 (and (re-search-backward mh-letter-header-field-regexp nil t
)
1928 (intern (downcase (match-string 1))))))
1931 (defun mh-letter-next-header-field-or-indent (arg)
1932 "Move to next field or indent depending on point.
1933 Within the header of the message, this command moves between
1934 fields, but skips those fields listed in
1935 `mh-compose-skipped-header-fields'. After the last field, this
1936 command then moves point to the message body before cycling back
1937 to the first field. If point is already past the first line of
1938 the message body, then this command indents by calling
1939 `indent-relative' with the given prefix argument ARG."
1941 (let ((header-end (save-excursion
1942 (goto-char (mh-mail-header-end))
1945 (if (> (point) header-end
)
1946 (indent-relative arg
)
1947 (mh-letter-next-header-field))))
1949 (defun mh-letter-next-header-field ()
1950 "Cycle to the next header field.
1951 If we are at the last header field go to the start of the message
1953 (let ((header-end (mh-mail-header-end)))
1954 (cond ((>= (point) header-end
) (goto-char (point-min)))
1957 (re-search-forward mh-letter-header-field-regexp
1958 (line-end-position) t
)
1960 (beginning-of-line))
1962 (cond ((re-search-forward mh-letter-header-field-regexp header-end t
)
1963 (if (mh-letter-skipped-header-field-p (match-string 1))
1964 (mh-letter-next-header-field)
1965 (mh-letter-skip-leading-whitespace-in-header-field)))
1966 (t (goto-char header-end
)
1970 (defun mh-letter-previous-header-field ()
1971 "Cycle to the previous header field.
1972 This command moves backwards between the fields and cycles to the
1973 body of the message after the first field. Unlike the
1974 \\[mh-letter-next-header-field-or-indent] command, it will always
1975 take point to the last field from anywhere in the body."
1977 (let ((header-end (mh-mail-header-end)))
1978 (if (>= (point) header-end
)
1979 (goto-char header-end
)
1980 (mh-header-field-beginning))
1981 (cond ((re-search-backward mh-letter-header-field-regexp nil t
)
1982 (if (mh-letter-skipped-header-field-p (match-string 1))
1983 (mh-letter-previous-header-field)
1984 (goto-char (match-end 0))
1985 (mh-letter-skip-leading-whitespace-in-header-field)))
1986 (t (goto-char header-end
)
1989 (defun mh-letter-skipped-header-field-p (field)
1990 "Check if FIELD is to be skipped."
1991 (let ((field (downcase field
)))
1992 (loop for x in mh-compose-skipped-header-fields
1993 when
(equal (downcase x
) field
) return t
1994 finally return nil
)))
1996 (defun mh-letter-skip-leading-whitespace-in-header-field ()
1997 "Skip leading whitespace in a header field.
1998 If the header field doesn't have at least one space after the
1999 colon then a space character is added."
2000 (let ((need-space t
))
2001 (while (memq (char-after) '(?
\t ?\
))
2003 (setq need-space nil
))
2004 (when need-space
(insert " "))))
2006 (defvar mh-hidden-header-keymap
2007 (let ((map (make-sparse-keymap)))
2009 (define-key map
[mouse-2
] 'mh-letter-toggle-header-field-display-button
))
2011 (define-key map
'(button2)
2012 'mh-letter-toggle-header-field-display-button
))
2015 (defun mh-letter-toggle-header-field-display-button (event)
2016 "Toggle header field display at location of EVENT.
2017 This function does the same thing as
2018 `mh-letter-toggle-header-field-display' except that it is
2019 callable from a mouse button."
2021 (mh-do-at-event-location event
2022 (mh-letter-toggle-header-field-display nil
)))
2024 (defun mh-letter-toggle-header-field-display (arg)
2025 "Toggle display of header field at point.
2027 Use this command to display truncated header fields. This command
2028 is a toggle so entering it again will hide the field. This
2029 command takes a prefix argument ARG: if negative then the field
2030 is hidden, if positive then the field is displayed."
2031 (interactive (list nil
))
2032 (when (and (mh-in-header-p)
2035 (re-search-backward mh-letter-header-field-regexp nil t
)))
2036 (let ((buffer-read-only nil
)
2037 (modified-flag (buffer-modified-p))
2041 (setq end
(1- (if (re-search-forward "^[^ \t]" nil t
)
2045 ;; Make it clickable...
2046 (add-text-properties begin end
`(keymap ,mh-hidden-header-keymap
2047 mouse-face highlight
))
2049 (cond ((or (and (not arg
)
2050 (text-property-any begin end
'invisible
'vanish
))
2051 (and (numberp arg
) (>= arg
0))
2052 (and (eq arg
'long
) (> (line-beginning-position 5) end
)))
2053 (remove-text-properties begin end
'(invisible nil
))
2054 (search-forward ":" (line-end-position) t
)
2055 (mh-letter-skip-leading-whitespace-in-header-field))
2056 ;; XXX Redesign to make usable by user. Perhaps use a positive
2057 ;; numeric prefix to make that many lines visible.
2060 (mh-letter-truncate-header-field end
)
2061 (beginning-of-line))
2063 (mh-letter-truncate-header-field end
)
2064 (beginning-of-line)))
2065 (set-buffer-modified-p modified-flag
)))))
2067 (defun mh-letter-truncate-header-field (end)
2068 "Replace text from current line till END with an ellipsis.
2069 If the current line is too long truncate a part of it as well."
2070 (let ((max-len (min (window-width) 62)))
2071 (when (> (+ (current-column) 4) max-len
)
2072 (backward-char (- (+ (current-column) 5) max-len
)))
2073 (when (> end
(point))
2074 (add-text-properties (point) end
'(invisible vanish
)))))
2076 (defun mh-letter-hide-all-skipped-fields ()
2077 "Hide all skipped fields."
2079 (goto-char (point-min))
2081 (narrow-to-region (point) (mh-mail-header-end))
2082 (while (re-search-forward mh-letter-header-field-regexp nil t
)
2083 (if (mh-letter-skipped-header-field-p (match-string 1))
2084 (mh-letter-toggle-header-field-display -
1)
2085 (mh-letter-toggle-header-field-display 'long
))
2086 (beginning-of-line 2)))))
2088 (defun mh-interactive-read-address (prompt)
2090 If `mh-compose-prompt-flag' is non-nil, then read an address with
2092 Otherwise return the empty string."
2093 (if mh-compose-prompt-flag
(mh-read-address prompt
) ""))
2095 (defun mh-interactive-read-string (prompt)
2097 If `mh-compose-prompt-flag' is non-nil, then read a string with
2099 Otherwise return the empty string."
2100 (if mh-compose-prompt-flag
(read-string prompt
) ""))
2102 (defun mh-letter-adjust-point ()
2103 "Move cursor to first header field if are using the no prompt mode."
2104 (unless mh-compose-prompt-flag
2105 (goto-char (point-max))
2106 (mh-letter-next-header-field)))
2110 ;;; Build mh-letter-mode keymap
2112 ;; If this changes, modify mh-letter-mode-help-messages accordingly, above.
2113 (gnus-define-keys mh-letter-mode-map
2114 " " mh-letter-complete-or-space
2115 "," mh-letter-confirm-address
2117 "\C-c\C-\\" mh-fully-kill-draft
;if no C-q
2118 "\C-c\C-^" mh-insert-signature
;if no C-s
2119 "\C-c\C-c" mh-send-letter
2120 "\C-c\C-d" mh-insert-identity
2121 "\C-c\C-e" mh-mh-to-mime
2122 "\C-c\C-f\C-b" mh-to-field
2123 "\C-c\C-f\C-c" mh-to-field
2124 "\C-c\C-f\C-d" mh-to-field
2125 "\C-c\C-f\C-f" mh-to-fcc
2126 "\C-c\C-f\C-r" mh-to-field
2127 "\C-c\C-f\C-s" mh-to-field
2128 "\C-c\C-f\C-t" mh-to-field
2129 "\C-c\C-fb" mh-to-field
2130 "\C-c\C-fc" mh-to-field
2131 "\C-c\C-fd" mh-to-field
2132 "\C-c\C-ff" mh-to-fcc
2133 "\C-c\C-fr" mh-to-field
2134 "\C-c\C-fs" mh-to-field
2135 "\C-c\C-ft" mh-to-field
2136 "\C-c\C-i" mh-insert-letter
2137 "\C-c\C-m\C-e" mh-mml-secure-message-encrypt
2138 "\C-c\C-m\C-f" mh-compose-forward
2139 "\C-c\C-m\C-g" mh-mh-compose-anon-ftp
2140 "\C-c\C-m\C-i" mh-compose-insertion
2141 "\C-c\C-m\C-m" mh-mml-to-mime
2142 "\C-c\C-m\C-n" mh-mml-unsecure-message
2143 "\C-c\C-m\C-s" mh-mml-secure-message-sign
2144 "\C-c\C-m\C-t" mh-mh-compose-external-compressed-tar
2145 "\C-c\C-m\C-u" mh-mh-to-mime-undo
2146 "\C-c\C-m\C-x" mh-mh-compose-external-type
2147 "\C-c\C-mee" mh-mml-secure-message-encrypt
2148 "\C-c\C-mes" mh-mml-secure-message-signencrypt
2149 "\C-c\C-mf" mh-compose-forward
2150 "\C-c\C-mg" mh-mh-compose-anon-ftp
2151 "\C-c\C-mi" mh-compose-insertion
2152 "\C-c\C-mm" mh-mml-to-mime
2153 "\C-c\C-mn" mh-mml-unsecure-message
2154 "\C-c\C-mse" mh-mml-secure-message-signencrypt
2155 "\C-c\C-mss" mh-mml-secure-message-sign
2156 "\C-c\C-mt" mh-mh-compose-external-compressed-tar
2157 "\C-c\C-mu" mh-mh-to-mime-undo
2158 "\C-c\C-mx" mh-mh-compose-external-type
2159 "\C-c\C-o" mh-open-line
2160 "\C-c\C-q" mh-fully-kill-draft
2161 "\C-c\C-s" mh-insert-signature
2162 "\C-c\C-t" mh-letter-toggle-header-field-display
2163 "\C-c\C-w" mh-check-whom
2164 "\C-c\C-y" mh-yank-cur-msg
2165 "\C-c\M-d" mh-insert-auto-fields
2166 "\M-\t" mh-letter-complete
2167 "\t" mh-letter-next-header-field-or-indent
2168 [backtab] mh-letter-previous-header-field)
2170 ;; "C-c /" prefix is used in mh-letter-mode by pgp.el and mailcrypt.el.
2175 ;; indent-tabs-mode: nil
2176 ;; sentence-end-double-space: nil
2179 ;; arch-tag: 62865511-e610-4923-b0b5-f45a8ab70a34
2180 ;;; mh-comp.el ends here