1 ;;; mh-comp.el --- MH-E functions for composing messages
3 ;; Copyright (C) 1993,1995,1997,2000,2001,2002 Free Software Foundation, Inc.
5 ;; Author: Bill Wohler <wohler@newt.com>
6 ;; Maintainer: Bill Wohler <wohler@newt.com>
10 ;; This file is part of GNU Emacs.
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 2, or (at your option)
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.
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with GNU Emacs; see the file COPYING. If not, write to the
24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25 ;; Boston, MA 02111-1307, USA.
29 ;; Internal support for MH-E package.
33 ;; $Id: mh-comp.el,v 1.2 2003/02/03 20:55:30 wohler Exp $
42 ;; Shush the byte-compiler
43 (defvar adaptive-fill-first-line-regexp
)
44 (defvar font-lock-defaults
)
46 (defvar sendmail-coding-system
)
47 (defvar mh-identity-list
)
48 (defvar mh-identity-default
)
49 (defvar mh-identity-menu
)
52 (autoload 'Info-goto-node
"info")
53 (autoload 'mail-mode-fill-paragraph
"sendmail")
54 (autoload 'mm-handle-displayed-p
"mm-decode")
56 (autoload 'sc-cite-original
"sc"
57 "Workhorse citing function which performs the initial citation.
58 This is callable from the various mail and news readers' reply
59 function according to the agreed upon standard. See `\\[sc-describe]'
60 for more details. `sc-cite-original' does not do any yanking of the
61 original message but it does require a few things:
63 1) The reply buffer is the current buffer.
65 2) The original message has been yanked and inserted into the
68 3) Verbose mail headers from the original message have been
69 inserted into the reply buffer directly before the text of the
72 4) Point is at the beginning of the verbose headers.
74 5) Mark is at the end of the body of text to be cited.
76 For Emacs 19's, the region need not be active (and typically isn't
77 when this function is called. Also, the hook `sc-pre-hook' is run
78 before, and `sc-post-hook' is run after the guts of this function.")
80 ;;; Site customization (see also mh-utils.el):
82 (defvar mh-send-prog
"send"
83 "Name of the MH send program.
84 Some sites need to change this because of a name conflict.")
86 (defvar mh-redist-full-contents nil
87 "Non-nil if the `dist' command needs whole letter for redistribution.
88 This is the case only when `send' is compiled with the BERK option.
89 If MH will not allow you to redist a previously redist'd msg, set to nil.")
91 (defvar mh-redist-background nil
92 "If non-nil redist will be done in background like send.
93 This allows transaction log to be visible if -watch, -verbose or -snoop are
96 (defvar mh-note-repl
"-"
97 "String whose first character is used to notate replied to messages.")
99 (defvar mh-note-forw
"F"
100 "String whose first character is used to notate forwarded messages.")
102 (defvar mh-note-dist
"R"
103 "String whose first character is used to notate redistributed messages.")
105 (defvar mh-yank-hooks nil
106 "Obsolete hook for modifying a citation just inserted in the mail buffer.
107 Each hook function can find the citation between point and mark.
108 And each hook function should leave point and mark around the citation
111 This is a normal hook, misnamed for historical reasons.
112 It is semi-obsolete and is only used if `mail-citation-hook' is nil.")
114 (defvar mail-citation-hook nil
115 "*Hook for modifying a citation just inserted in the mail buffer.
116 Each hook function can find the citation between point and mark.
117 And each hook function should leave point and mark around the citation
120 If this hook is entirely empty (nil), the text of the message is inserted
121 with `mh-ins-buf-prefix' prefixed to each line.
123 See also the variable `mh-yank-from-start-of-msg', which controls how
124 much of the message passed to the hook.
126 This hook was historically provided to set up supercite. You may now leave
127 this nil and set up supercite by setting the variable
128 `mh-yank-from-start-of-msg' to 'supercite or, for more automatic insertion,
131 (defvar mh-comp-formfile
"components"
132 "Name of file to be used as a skeleton for composing messages.
133 Default is \"components\". If not an absolute file name, the file
134 is searched for first in the user's MH directory, then in the
135 system MH lib directory.")
137 (defvar mh-repl-formfile
"replcomps"
138 "Name of file to be used as a skeleton for replying to messages.
139 Default is \"replcomps\". If not an absolute file name, the file
140 is searched for first in the user's MH directory, then in the
141 system MH lib directory.")
143 (defvar mh-repl-group-formfile
"replgroupcomps"
144 "Name of file to be used as a skeleton for replying to messages.
145 This file is used to form replies to the sender and all recipients of a
146 message. Only used if `mh-nmh-flag' is non-nil. Default is \"replgroupcomps\".
147 If not an absolute file name, the file is searched for first in the user's MH
148 directory, then in the system MH lib directory.")
150 (defvar mh-rejected-letter-start
153 '("Content-Type: message/rfc822" ;MIME MDN
154 " ----- Unsent message follows -----" ;from sendmail V5
155 " --------Unsent Message below:" ; from sendmail at BU
156 " ----- Original message follows -----" ;from sendmail V8
157 "------- Unsent Draft" ;from MH itself
158 "---------- Original Message ----------" ;from zmailer
159 " --- The unsent message follows ---" ;from AIX mail system
160 " Your message follows:" ;from MMDF-II
161 "Content-Description: Returned Content" ;1993 KJ sendmail
164 (defvar mh-new-draft-cleaned-headers
165 "^Date:\\|^Received:\\|^Message-Id:\\|^From:\\|^Sender:\\|^Errors-To:\\|^Delivery-Date:\\|^Return-Path:"
166 "Regexp of header lines to remove before offering a message as a new draft.
167 Used by the \\<mh-folder-mode-map>`\\[mh-edit-again]' and `\\[mh-extract-rejected-mail]' commands.")
169 (defvar mh-to-field-choices
'(("t" .
"To:") ("s" .
"Subject:") ("c" .
"Cc:")
170 ("b" .
"Bcc:") ("f" .
"Fcc:") ("r" .
"From:")
172 "Alist of (final-character . field-name) choices for `mh-to-field'.")
174 (defvar mh-letter-mode-map
(copy-keymap text-mode-map
)
175 "Keymap for composing mail.")
177 (defvar mh-letter-mode-syntax-table nil
178 "Syntax table used by MH-E while in MH-Letter mode.")
180 (if mh-letter-mode-syntax-table
182 (setq mh-letter-mode-syntax-table
183 (make-syntax-table text-mode-syntax-table
))
184 (modify-syntax-entry ?%
"." mh-letter-mode-syntax-table
))
186 (defvar mh-sent-from-folder nil
187 "Folder of msg assoc with this letter.")
189 (defvar mh-sent-from-msg nil
190 "Number of msg assoc with this letter.")
192 (defvar mh-send-args nil
193 "Extra args to pass to \"send\" command.")
195 (defvar mh-annotate-char nil
196 "Character to use to annotate `mh-sent-from-msg'.")
198 (defvar mh-annotate-field nil
199 "Field name for message annotation.")
203 "Compose and send mail with the MH mail system.
204 This function is an entry point to MH-E, the Emacs front end
205 to the MH mail system.
207 See documentation of `\\[mh-send]' for more details on composing mail."
210 (call-interactively 'mh-send
))
212 (defvar mh-error-if-no-draft nil
) ;raise error over using old draft
215 (defun mh-smail-batch (&optional to subject other-headers
&rest ignored
)
216 "Set up a mail composition draft with the MH mail system.
217 This function is an entry point to MH-E, the Emacs front end
218 to the MH mail system. This function does not prompt the user
219 for any header fields, and thus is suitable for use by programs
220 that want to create a mail buffer.
221 Users should use `\\[mh-smail]' to compose mail.
222 Optional arguments for setting certain fields include TO, SUBJECT, and
223 OTHER-HEADERS. Additional arguments are IGNORED."
225 (let ((mh-error-if-no-draft t
))
226 (mh-send (or to
"") "" (or subject
""))))
228 ;; XEmacs needs this:
230 (defun mh-user-agent-compose (&optional to subject other-headers continue
231 switch-function yank-action
233 "Set up mail composition draft with the MH mail system.
234 This is `mail-user-agent' entry point to MH-E.
236 The optional arguments TO and SUBJECT specify recipients and the
237 initial Subject field, respectively.
239 OTHER-HEADERS is an alist specifying additional
240 header fields. Elements look like (HEADER . VALUE) where both
241 HEADER and VALUE are strings.
243 CONTINUE, SWITCH-FUNCTION, YANK-ACTION and SEND-ACTIONS are ignored."
245 (let ((mh-error-if-no-draft t
))
246 (mh-send to
"" subject
)
248 (mh-insert-fields (concat (car (car other-headers
)) ":")
249 (cdr (car other-headers
)))
250 (setq other-headers
(cdr other-headers
)))))
253 (defun mh-edit-again (msg)
254 "Clean up a draft or a message MSG previously sent and make it resendable.
255 Default is the current message.
256 The variable `mh-new-draft-cleaned-headers' specifies the headers to remove.
257 See also documentation for `\\[mh-send]' function."
258 (interactive (list (mh-get-msg-num t
)))
259 (let* ((from-folder mh-current-folder
)
260 (config (current-window-configuration))
262 (cond ((and mh-draft-folder
(equal from-folder mh-draft-folder
))
263 (pop-to-buffer (find-file-noselect (mh-msg-filename msg
)) t
)
264 (rename-buffer (format "draft-%d" msg
))
265 ;; Make buffer writable...
266 (setq buffer-read-only nil
)
267 ;; If buffer was being used to display the message reinsert
269 (when (eq major-mode
'mh-show-mode
)
271 (insert-file-contents buffer-file-name
))
274 (mh-read-draft "clean-up" (mh-msg-filename msg
) nil
)))))
275 (mh-clean-msg-header (point-min) mh-new-draft-cleaned-headers nil
)
276 (mh-insert-header-separator)
277 (goto-char (point-min))
279 (mh-compose-and-send-mail draft
"" from-folder nil nil nil nil nil nil
281 (mh-letter-mode-message)))
284 (defun mh-extract-rejected-mail (msg)
285 "Extract message MSG returned by the mail system and make it resendable.
286 Default is the current message. The variable `mh-new-draft-cleaned-headers'
287 gives the headers to clean out of the original message.
288 See also documentation for `\\[mh-send]' function."
289 (interactive (list (mh-get-msg-num t
)))
290 (let ((from-folder mh-current-folder
)
291 (config (current-window-configuration))
292 (draft (mh-read-draft "extraction" (mh-msg-filename msg
) nil
)))
293 (goto-char (point-min))
294 (cond ((re-search-forward mh-rejected-letter-start nil t
)
295 (skip-chars-forward " \t\n")
296 (delete-region (point-min) (point))
297 (mh-clean-msg-header (point-min) mh-new-draft-cleaned-headers nil
))
299 (message "Does not appear to be a rejected letter.")))
300 (mh-insert-header-separator)
301 (goto-char (point-min))
303 (mh-compose-and-send-mail draft
"" from-folder msg
304 (mh-get-header-field "To:")
305 (mh-get-header-field "From:")
306 (mh-get-header-field "Cc:")
308 (mh-letter-mode-message)))
311 (defun mh-forward (to cc
&optional msg-or-seq
)
312 "Forward one or more messages to the recipients TO and CC.
314 Use the optional MSG-OR-SEQ to specify a message or sequence to forward.
316 Default is the displayed message. If optional prefix argument is given then
317 prompt for the message sequence. If variable `transient-mark-mode' is non-nil
318 and the mark is active, then the selected region is forwarded.
319 See also documentation for `\\[mh-send]' function."
320 (interactive (list (mh-read-address "To: ")
321 (mh-read-address "Cc: ")
323 ((mh-mark-active-p t
)
324 (mh-region-to-msg-list (region-beginning) (region-end)))
326 (mh-read-seq-default "Forward" t
))
328 (mh-get-msg-num t
)))))
329 (let* ((folder mh-current-folder
)
330 (msgs (cond ((numberp msg-or-seq
) (list msg-or-seq
))
331 ((listp msg-or-seq
) msg-or-seq
)
332 (t (mh-seq-to-msgs msg-or-seq
))))
333 (config (current-window-configuration))
334 (fwd-msg-file (mh-msg-filename (car msgs
) folder
))
335 ;; forw always leaves file in "draft" since it doesn't have -draft
336 (draft-name (expand-file-name "draft" mh-user-path
))
337 (draft (cond ((or (not (file-exists-p draft-name
))
338 (y-or-n-p "The file 'draft' exists. Discard it? "))
339 (mh-exec-cmd "forw" "-build" (if mh-nmh-flag
"-mime")
340 mh-current-folder msgs
)
342 (mh-read-draft "" draft-name t
)
343 (mh-insert-fields "To:" to
"Cc:" cc
)
346 (mh-read-draft "" draft-name nil
)))))
350 (set-buffer (get-buffer-create mh-temp-buffer
))
352 (insert-file-contents fwd-msg-file
)
353 (setq orig-from
(mh-get-header-field "From:"))
354 (setq orig-subject
(mh-get-header-field "Subject:")))
356 (mh-forwarded-letter-subject orig-from orig-subject
))
358 (mh-insert-fields "Subject:" forw-subject
)
359 (goto-char (point-min))
360 ;; If using MML, translate mhn
361 (if (equal mh-compose-insertion
'gnus
)
364 (re-search-forward (format "^\\(%s\\)?$"
365 mh-mail-header-separator
))
368 "^#forw \\[\\([^]]+\\)\\] \\(+\\S-+\\) \\(.*\\)$"
370 (let ((description (if (equal (match-string 1)
371 "forwarded messages")
372 "forwarded message %d"
374 (msgs (split-string (match-string 3)))
377 (delete-region (point) (progn (forward-line 1) (point)))
380 (mh-mml-forward-message (format description i
)
382 ;; Postition just before forwarded message
383 (if (re-search-forward "^------- Forwarded Message" nil t
)
385 (re-search-forward (format "^\\(%s\\)?$" mh-mail-header-separator
))
387 (delete-other-windows)
388 (mh-add-msgs-to-seq msgs
'forwarded t
)
389 (mh-compose-and-send-mail draft
"" folder msg-or-seq
391 mh-note-forw
"Forwarded:"
394 (setq mh-mml-compose-insert-flag t
))
395 (mh-letter-mode-message)))))
397 (defun mh-forwarded-letter-subject (from subject
)
398 "Return a Subject suitable for a forwarded message.
399 Original message has headers FROM and SUBJECT."
400 (let ((addr-start (string-match "<" from
))
401 (comment (string-match "(" from
)))
402 (cond ((and addr-start
(> addr-start
0))
403 ;; Full Name <luser@host>
404 (setq from
(substring from
0 (1- addr-start
))))
406 ;; luser@host (Full Name)
407 (setq from
(substring from
(1+ comment
) (1- (length from
)))))))
408 (format mh-forward-subject-format from subject
))
411 (defun mh-smail-other-window ()
412 "Compose and send mail in other window with the MH mail system.
413 This function is an entry point to MH-E, the Emacs front end
414 to the MH mail system.
416 See documentation of `\\[mh-send]' for more details on composing mail."
419 (call-interactively 'mh-send-other-window
))
422 (defun mh-redistribute (to cc
&optional msg
)
423 "Redistribute displayed message to recipients TO and CC.
424 Use optional argument MSG to redistribute another message.
425 Depending on how your copy of MH was compiled, you may need to change the
426 setting of the variable `mh-redist-full-contents'. See its documentation."
427 (interactive (list (mh-read-address "Redist-To: ")
428 (mh-read-address "Redist-Cc: ")
431 (setq msg
(mh-get-msg-num t
)))
432 (save-window-excursion
433 (let ((folder mh-current-folder
)
434 (draft (mh-read-draft "redistribution"
435 (if mh-redist-full-contents
436 (mh-msg-filename msg
)
439 (mh-goto-header-end 0)
440 (insert "Resent-To: " to
"\n")
441 (if (not (equal cc
"")) (insert "Resent-cc: " cc
"\n"))
442 (mh-clean-msg-header (point-min)
443 "^Message-Id:\\|^Received:\\|^Return-Path:\\|^Sender:\\|^Date:\\|^From:"
446 (message "Redistributing...")
447 (if (not mh-redist-background
)
448 (if mh-redist-full-contents
449 (call-process "/bin/sh" nil
0 nil
"-c"
450 (format "mhdist=1 mhaltmsg=%s %s -push %s"
452 (expand-file-name mh-send-prog mh-progs
)
454 (call-process "/bin/sh" nil
0 nil
"-c"
456 "mhdist=1 mhaltmsg=%s mhannotate=1 %s -push %s"
457 (mh-msg-filename msg folder
)
458 (expand-file-name mh-send-prog mh-progs
)
460 (mh-annotate-msg msg folder mh-note-dist
461 "-component" "Resent:"
462 "-text" (format "\"%s %s\"" to cc
))
463 (if mh-redist-background
464 (mh-exec-cmd-daemon "/bin/sh" nil
"-c"
465 (format "mhdist=1 mhaltmsg=%s %s %s %s"
466 (if mh-redist-full-contents
468 (mh-msg-filename msg folder
))
469 (if mh-redist-full-contents
472 (mh-expand-file-name "send" mh-progs
)
475 (message "Redistributing...done"))))
477 (defun mh-show-buffer-message-number (&optional buffer
)
478 "Message number of displayed message in corresponding show buffer.
479 Return nil if show buffer not displayed.
480 If in `mh-letter-mode', don't display the message number being replied to,
481 but rather the message number of the show buffer associated with our
482 originating folder buffer.
483 Optional argument BUFFER can be used to specify the buffer."
487 (cond ((eq major-mode
'mh-show-mode
)
488 (let ((number-start (mh-search-from-end ?
/ buffer-file-name
)))
489 (car (read-from-string (substring buffer-file-name
490 (1+ number-start
))))))
491 ((and (eq major-mode
'mh-folder-mode
)
493 (get-buffer mh-show-buffer
))
494 (mh-show-buffer-message-number mh-show-buffer
))
495 ((and (eq major-mode
'mh-letter-mode
)
497 (get-buffer mh-sent-from-folder
))
498 (mh-show-buffer-message-number mh-sent-from-folder
))
503 (defun mh-reply (message &optional reply-to includep
)
504 "Reply to MESSAGE (default: current message).
505 If the optional argument REPLY-TO is not given, prompts for type of addresses
508 to sender and primary recipients,
509 cc/all sender and all recipients.
510 If optional prefix argument INCLUDEP provided, then include the message
511 in the reply using filter `mhl.reply' in your MH directory.
512 If the file named by `mh-repl-formfile' exists, it is used as a skeleton
513 for the reply. See also documentation for `\\[mh-send]' function."
516 (let ((minibuffer-help-form
517 "from => Sender only\nto => Sender and primary recipients\ncc or all => Sender and all recipients"))
518 (or mh-reply-default-reply-to
519 (completing-read "Reply to whom? (from, to, all) [from]: "
520 '(("from") ("to") ("cc") ("all"))
524 (let* ((folder mh-current-folder
)
525 (show-buffer mh-show-buffer
)
526 (config (current-window-configuration))
527 (group-reply (or (equal reply-to
"cc") (equal reply-to
"all")))
528 (form-file (cond ((and mh-nmh-flag group-reply
529 (stringp mh-repl-group-formfile
))
530 mh-repl-group-formfile
)
531 ((stringp mh-repl-formfile
) mh-repl-formfile
)
533 (message "Composing a reply...")
534 (mh-exec-cmd "repl" "-build" "-noquery" "-nodraftfolder"
536 (list "-form" form-file
))
537 mh-current-folder message
538 (cond ((or (equal reply-to
"from") (equal reply-to
""))
540 ((equal reply-to
"to")
542 (group-reply (if mh-nmh-flag
543 '("-group" "-nocc" "me")
544 '("-cc" "all" "-nocc" "me"))))
545 (cond ((or (eq mh-yank-from-start-of-msg
'autosupercite
)
546 (eq mh-yank-from-start-of-msg
'autoattrib
))
548 (includep '("-filter" "mhl.reply"))
550 (let ((draft (mh-read-draft "reply"
551 (expand-file-name "reply" mh-user-path
)
553 (delete-other-windows)
556 (let ((to (mh-get-header-field "To:"))
557 (subject (mh-get-header-field "Subject:"))
558 (cc (mh-get-header-field "Cc:")))
559 (goto-char (point-min))
560 (mh-goto-header-end 1)
562 (not mh-reply-show-message-flag
)
563 (mh-in-show-buffer (show-buffer)
564 (mh-display-msg message folder
)))
565 (mh-add-msgs-to-seq message
'answered t
)
566 (message "Composing a reply...done")
567 (mh-compose-and-send-mail draft
"" folder message to subject cc
568 mh-note-repl
"Replied:" config
))
569 (when (and (or (eq 'autosupercite mh-yank-from-start-of-msg
)
570 (eq 'autoattrib mh-yank-from-start-of-msg
))
571 (eq (mh-show-buffer-message-number) mh-sent-from-msg
))
574 (mh-letter-mode-message))))
577 (defun mh-send (to cc subject
)
578 "Compose and send a letter.
580 Do not call this function from outside MH-E; use \\[mh-smail] instead.
582 The file named by `mh-comp-formfile' will be used as the form.
583 The letter is composed in `mh-letter-mode'; see its documentation for more
585 If `mh-compose-letter-function' is defined, it is called on the draft and
586 passed three arguments: TO, CC, and SUBJECT."
588 (mh-read-address "To: ")
589 (mh-read-address "Cc: ")
590 (read-string "Subject: ")))
591 (let ((config (current-window-configuration)))
592 (delete-other-windows)
593 (mh-send-sub to cc subject config
)))
596 (defun mh-send-other-window (to cc subject
)
597 "Compose and send a letter in another window.
599 Do not call this function from outside MH-E; use \\[mh-smail-other-window]
602 The file named by `mh-comp-formfile' will be used as the form.
603 The letter is composed in `mh-letter-mode'; see its documentation for more
605 If `mh-compose-letter-function' is defined, it is called on the draft and
606 passed three arguments: TO, CC, and SUBJECT."
608 (mh-read-address "To: ")
609 (mh-read-address "Cc: ")
610 (read-string "Subject: ")))
611 (let ((pop-up-windows t
))
612 (mh-send-sub to cc subject
(current-window-configuration))))
614 (defun mh-send-sub (to cc subject config
)
615 "Do the real work of composing and sending a letter.
616 Expects the TO, CC, and SUBJECT fields as arguments.
617 CONFIG is the window configuration before sending mail."
618 (let ((folder mh-current-folder
)
619 (msg-num (mh-get-msg-num nil
)))
620 (message "Composing a message...")
621 (let ((draft (mh-read-draft
627 (expand-file-name mh-comp-formfile mh-user-path
)))
631 (expand-file-name mh-comp-formfile mh-lib
)))
635 (expand-file-name mh-comp-formfile
636 ;; What is this mh-etc ?? -sm
637 ;; This is dead code, so
639 ;(and (boundp 'mh-etc) mh-etc)
643 (error (format "Can't find components file \"%s\""
646 (mh-insert-fields "To:" to
"Subject:" subject
"Cc:" cc
)
647 (goto-char (point-max))
648 (mh-compose-and-send-mail draft
"" folder msg-num
651 (mh-letter-mode-message))))
653 (defun mh-read-draft (use initial-contents delete-contents-file
)
654 "Read draft file into a draft buffer and make that buffer the current one.
655 USE is a message used for prompting about the intended use of the message.
656 INITIAL-CONTENTS is filename that is read into an empty buffer, or nil
657 if buffer should not be modified. Delete the initial-contents file if
658 DELETE-CONTENTS-FILE flag is set.
659 Returns the draft folder's name.
660 If the draft folder facility is enabled in ~/.mh_profile, a new buffer is
661 used each time and saved in the draft folder. The draft file can then be
663 (cond (mh-draft-folder
664 (let ((orig-default-dir default-directory
)
665 (draft-file-name (mh-new-draft-name)))
666 (pop-to-buffer (generate-new-buffer
668 (file-name-nondirectory draft-file-name
))))
670 (insert-file-contents draft-file-name t
)
672 (setq default-directory orig-default-dir
)))
674 (let ((draft-name (expand-file-name "draft" mh-user-path
)))
675 (pop-to-buffer "draft") ; Create if necessary
676 (if (buffer-modified-p)
677 (if (y-or-n-p "Draft has been modified; kill anyway? ")
678 (set-buffer-modified-p nil
)
679 (error "Draft preserved")))
680 (setq buffer-file-name draft-name
)
681 (clear-visited-file-modtime)
683 (cond ((and (file-exists-p draft-name
)
684 (not (equal draft-name initial-contents
)))
685 (insert-file-contents draft-name
)
686 (delete-file draft-name
))))))
687 (cond ((and initial-contents
688 (or (zerop (buffer-size))
690 (format "A draft exists. Use for %s? " use
))
691 (if mh-error-if-no-draft
692 (error "A prior draft exists"))
695 (insert-file-contents initial-contents
)
696 (if delete-contents-file
(delete-file initial-contents
))))
699 (save-buffer)) ; Do not reuse draft name
702 (defun mh-new-draft-name ()
703 "Return the pathname of folder for draft messages."
705 (mh-exec-cmd-quiet t
"mhpath" mh-draft-folder
"new")
706 (buffer-substring (point-min) (1- (point-max)))))
708 (defun mh-annotate-msg (msg buffer note
&rest args
)
709 "Mark MSG in BUFFER with character NOTE and annotate message with ARGS."
710 (apply 'mh-exec-cmd
"anno" buffer msg args
)
712 (cond ((get-buffer buffer
) ; Buffer may be deleted
715 (mh-notate msg note
(1+ mh-cmd-note
))
716 (mh-notate-seq msg note
(1+ mh-cmd-note
)))))))
718 (defun mh-insert-fields (&rest name-values
)
719 "Insert the NAME-VALUES pairs in the current buffer.
720 If the field exists, append the value to it.
721 Do not insert any pairs whose value is the empty string."
722 (let ((case-fold-search t
))
724 (let ((field-name (car name-values
))
725 (value (car (cdr name-values
))))
726 (cond ((equal value
"")
728 ((mh-position-on-field field-name
)
729 (insert " " (or value
"")))
731 (insert field-name
" " value
"\n")))
732 (setq name-values
(cdr (cdr name-values
)))))))
734 (defun mh-position-on-field (field &optional ignored
)
735 "Move to the end of the FIELD in the header.
736 Move to end of entire header if FIELD not found.
737 Returns non-nil iff FIELD was found.
738 The optional second arg is for pre-version 4 compatibility and is IGNORED."
739 (cond ((mh-goto-header-field field
)
740 (mh-header-field-end)
742 ((mh-goto-header-end 0)
745 (defun mh-get-header-field (field)
746 "Find and return the body of FIELD in the mail header.
747 Returns the empty string if the field is not in the header of the
749 (if (mh-goto-header-field field
)
751 (skip-chars-forward " \t") ;strip leading white space in body
752 (let ((start (point)))
753 (mh-header-field-end)
754 (buffer-substring-no-properties start
(point))))
757 (fset 'mh-get-field
'mh-get-header-field
) ;MH-E 4 compatibility
759 (defun mh-goto-header-field (field)
760 "Move to FIELD in the message header.
761 Move to the end of the FIELD name, which should end in a colon.
762 Returns t if found, nil if not."
763 (goto-char (point-min))
764 (let ((case-fold-search t
)
765 (headers-end (save-excursion
766 (mh-goto-header-end 0)
768 (re-search-forward (format "^%s" field
) headers-end t
)))
770 (defun mh-goto-header-end (arg)
771 "Move the cursor ARG lines after the header."
772 (if (re-search-forward "^-*$" nil nil
)
775 (defun mh-extract-from-header-value ()
776 "Extract From: string from header."
778 (if (not (mh-goto-header-field "From:"))
779 (error "No From header line found")
780 (skip-chars-forward " \t")
781 (buffer-substring-no-properties
782 (point) (progn (mh-header-field-end)(point))))))
786 ;;; Mode for composing and sending a draft message.
788 (put 'mh-letter-mode
'mode-class
'special
)
790 ;;; Menu extracted from mh-menubar.el V1.1 (31 July 2001)
791 (eval-when-compile (defvar mh-letter-menu nil
))
793 ((fboundp 'easy-menu-define
)
795 mh-letter-menu mh-letter-mode-map
"Menu for MH-E letter mode."
797 ["Send This Draft" mh-send-letter t
]
798 ["Split Current Line" mh-open-line t
]
799 ["Check Recipient" mh-check-whom t
]
800 ["Yank Current Message" mh-yank-cur-msg t
]
801 ["Insert a Message..." mh-insert-letter t
]
802 ["Insert Signature" mh-insert-signature t
]
804 mh-mml-secure-message-sign-pgpmime mh-gnus-pgp-support-flag
]
805 ["GPG Encrypt message"
806 mh-mml-secure-message-encrypt-pgpmime mh-gnus-pgp-support-flag
]
807 ["Compose Insertion (MIME)..." mh-compose-insertion t
]
808 ;; ["Compose Compressed tar (MIME)..."
809 ;;mh-mhn-compose-external-compressed-tar t]
810 ;; ["Compose Anon FTP (MIME)..." mh-mhn-compose-anon-ftp t]
811 ["Compose Forward (MIME)..." mh-compose-forward t
]
812 ;; The next two will have to be merged. But I also need to make sure the
813 ;; user can't mix directives of both types.
814 ["Pull in All Compositions (mhn)"
815 mh-edit-mhn mh-mhn-compose-insert-flag
]
816 ["Pull in All Compositions (gnus)"
817 mh-mml-to-mime mh-mml-compose-insert-flag
]
818 ["Revert to Non-MIME Edit (mhn)"
819 mh-revert-mhn-edit
(equal mh-compose-insertion
'mhn
)]
820 ["Kill This Draft" mh-fully-kill-draft t
]))))
823 ;;; Group messages logically, more or less.
824 (defvar mh-letter-mode-help-messages
826 "Send letter: \\[mh-send-letter]"
827 "\t\tOpen line: \\[mh-open-line]\n"
828 "Kill letter: \\[mh-fully-kill-draft]"
830 "Check recipients: \\[mh-check-whom]"
831 "\t\t Current message: \\[mh-yank-cur-msg]\n"
832 "Encrypt message: \\[mh-mml-secure-message-encrypt-pgpmime]"
833 "\t\t Attachment: \\[mh-compose-insertion]\n"
834 "Sign message: \\[mh-mml-secure-message-sign-pgpmime]"
835 "\t\t Message to forward: \\[mh-compose-forward]\n"
837 "\t\t Signature: \\[mh-insert-signature]"))
838 "Key binding cheat sheet.
840 This is an associative array which is used to show the most common commands.
841 The key is a prefix char. The value is one or more strings which are
842 concatenated together and displayed in the minibuffer if ? is pressed after
843 the prefix character. The special key nil is used to display the
844 non-prefixed commands.
846 The substitutions described in `substitute-command-keys' are performed as
850 (defun mh-fill-paragraph-function (arg)
851 "Fill paragraph at or after point.
852 Prefix ARG means justify as well. This function enables `fill-paragraph' to
853 work better in MH-Letter mode."
855 (let ((fill-paragraph-function) (fill-prefix))
857 (mail-mode-fill-paragraph arg
)
858 (fill-paragraph arg
))))
861 (define-derived-mode mh-letter-mode text-mode
"MH-Letter"
862 "Mode for composing letters in MH-E.\\<mh-letter-mode-map>
864 When you have finished composing, type \\[mh-send-letter] to send the message
865 using the MH mail handling system.
867 There are two types of MIME directives used by MH-E: Gnus and MH. The option
868 `mh-compose-insertion' controls what type of directives are inserted by MH-E
869 commands. These directives can be converted to MIME body parts by running
870 \\[mh-edit-mhn] for mhn directives or \\[mh-mml-to-mime] for Gnus directives.
871 This step is mandatory if these directives are added manually. If the
872 directives are inserted with MH-E commands such as \\[mh-compose-insertion],
873 the directives are expanded automatically when the letter is sent.
875 Options that control this mode can be changed with
876 \\[customize-group]; specify the \"mh-compose\" group.
878 When a message is composed, the hooks `text-mode-hook' and
879 `mh-letter-mode-hook' are run.
881 \\{mh-letter-mode-map}"
883 (or mh-user-path
(mh-find-path))
884 (make-local-variable 'mh-send-args
)
885 (make-local-variable 'mh-annotate-char
)
886 (make-local-variable 'mh-annotate-field
)
887 (make-local-variable 'mh-previous-window-config
)
888 (make-local-variable 'mh-sent-from-folder
)
889 (make-local-variable 'mh-sent-from-msg
)
890 (make-local-variable 'mail-header-separator
)
891 (setq mail-header-separator mh-mail-header-separator
) ;override sendmail.el
892 (make-local-variable 'mh-help-messages
)
893 (setq mh-help-messages mh-letter-mode-help-messages
)
895 ;; From sendmail.el for proper paragraph fill
896 ;; sendmail.el also sets a normal-auto-fill-function (not done here)
897 (make-local-variable 'paragraph-separate
)
898 (make-local-variable 'paragraph-start
)
899 (make-local-variable 'fill-paragraph-function
)
900 (setq fill-paragraph-function
'mh-fill-paragraph-function
)
901 (make-local-variable 'adaptive-fill-regexp
)
902 (setq adaptive-fill-regexp
903 (concat adaptive-fill-regexp
904 "\\|[ \t]*[-[:alnum:]]*>+[ \t]*"))
905 (make-local-variable 'adaptive-fill-first-line-regexp
)
906 (setq adaptive-fill-first-line-regexp
907 (concat adaptive-fill-first-line-regexp
908 "\\|[ \t]*[-[:alnum:]]*>+[ \t]*"))
909 ;; `-- ' precedes the signature. `-----' appears at the start of the
910 ;; lines that delimit forwarded messages.
911 ;; Lines containing just >= 3 dashes, perhaps after whitespace,
912 ;; are also sometimes used and should be separators.
913 (setq paragraph-start
(concat (regexp-quote mail-header-separator
)
914 "\\|\t*\\([-|#;>* ]\\|(?[0-9]+[.)]\\)+$"
915 "\\|[ \t]*[[:alnum:]]*>+[ \t]*$\\|[ \t]*$\\|"
918 (setq paragraph-separate paragraph-start
)
919 ;; --- End of code from sendmail.el ---
921 (if (and (boundp 'tool-bar-mode
) tool-bar-mode
)
922 (set (make-local-variable 'tool-bar-map
) mh-letter-tool-bar-map
))
923 (make-local-variable 'font-lock-defaults
)
925 ((or (equal mh-highlight-citation-p
'font-lock
)
926 (equal mh-highlight-citation-p
'gnus
))
927 ;; Let's use font-lock even if gnus is used in show-mode. The reason
928 ;; is that gnus uses static text properties which are not appropriate
929 ;; for a buffer that will be edited. So the choice here is either fontify
930 ;; the citations and header...
931 (setq font-lock-defaults
'(mh-show-font-lock-keywords-with-cite t
)))
933 ;; ...or the header only
934 (setq font-lock-defaults
'(mh-show-font-lock-keywords t
))))
935 (easy-menu-add mh-letter-menu
)
936 ;; See if a "forw: -mime" message containing a MIME composition.
937 ;; Mode clears local vars, so can't do this in mh-forward.
939 (goto-char (point-min))
940 (when (and (re-search-forward
941 (format "^\\(%s\\)?$" mail-header-separator
) nil t
)
942 (= 0 (forward-line 1))
943 (looking-at "^#forw"))
944 (require 'mh-mime
) ;Need mh-mhn-compose-insert-flag local var
945 (setq mh-mhn-compose-insert-flag t
)))
946 (setq fill-column mh-letter-fill-column
)
947 ;; If text-mode-hook turned on auto-fill, tune it for messages
948 (when auto-fill-function
949 (make-local-variable 'auto-fill-function
)
950 (setq auto-fill-function
'mh-auto-fill-for-letter
)))
952 (defun mh-auto-fill-for-letter ()
953 "Perform auto-fill for message.
954 Header is treated specially by inserting a tab before continuation lines."
956 (let ((fill-prefix "\t"))
960 (defun mh-insert-header-separator ()
961 "Insert `mh-mail-header-separator', if absent."
963 (goto-char (point-min))
966 (insert mh-mail-header-separator
))))
969 (defun mh-to-field ()
970 "Move point to the end of a specified header field.
971 The field is indicated by the previous keystroke (the last keystroke
972 of the command) according to the list in the variable `mh-to-field-choices'.
973 Create the field if it does not exist. Set the mark to point before moving."
976 (let ((target (cdr (or (assoc (char-to-string (logior last-input-char ?
`))
978 ;; also look for a char for version 4 compat
979 (assoc (logior last-input-char ?
`)
980 mh-to-field-choices
))))
981 (case-fold-search t
))
983 (cond ((mh-position-on-field target
)
985 (skip-chars-backward " \t")
986 (delete-region (point) eol
))
987 (if (and (not (eq (logior last-input-char ?
`) ?s
))
990 (not (looking-at "[:,]"))))
994 (if (mh-position-on-field "To:")
996 (insert (format "%s \n" target
))
997 (backward-char 1)))))
1000 (defun mh-to-fcc (&optional folder
)
1001 "Insert an Fcc: FOLDER field in the current message.
1002 Prompt for the field name with a completion list of the current folders."
1005 (setq folder
(mh-prompt-for-folder
1007 (or (and mh-default-folder-for-message-function
1009 (goto-char (point-min))
1011 mh-default-folder-for-message-function
)))
1014 (let ((last-input-char ?\C-f
))
1018 (insert (if (mh-folder-name-p folder
)
1019 (substring folder
1)
1023 (defun mh-insert-signature ()
1024 "Insert the file named by `mh-signature-file-name' at point.
1025 The value of `mh-letter-insert-signature-hook' is a list of functions to be
1026 called, with no arguments, before the signature is actually inserted."
1028 (let ((mh-signature-file-name mh-signature-file-name
))
1029 (run-hooks 'mh-letter-insert-signature-hook
)
1030 (if mh-signature-file-name
1031 (insert-file-contents mh-signature-file-name
)))
1032 (force-mode-line-update))
1035 (defun mh-check-whom ()
1036 "Verify recipients of the current letter, showing expansion of any aliases."
1038 (let ((file-name buffer-file-name
))
1040 (message "Checking recipients...")
1041 (mh-in-show-buffer (mh-recipients-buffer)
1042 (bury-buffer (current-buffer))
1044 (mh-exec-cmd-output "whom" t file-name
))
1045 (message "Checking recipients...done")))
1047 (defun mh-tidy-draft-buffer ()
1048 "Run when a draft buffer is destroyed."
1049 (let ((buffer (get-buffer mh-recipients-buffer
)))
1051 (kill-buffer buffer
))))
1055 ;;; Routines to compose and send a letter.
1057 (defun mh-insert-x-face ()
1058 "Append X-Face field to header.
1059 If the field already exists, this function does nothing."
1060 (when (and (file-exists-p mh-x-face-file
)
1061 (file-readable-p mh-x-face-file
))
1063 (when (null (mh-position-on-field "X-Face"))
1065 (goto-char (+ (point) (cadr (insert-file-contents mh-x-face-file
))))
1066 (if (not (looking-at "^"))
1069 (defun mh-insert-x-mailer ()
1070 "Append an X-Mailer field to the header.
1071 The versions of MH-E, Emacs, and MH are shown."
1073 ;; Lazily initialize mh-x-mailer-string.
1074 (when (null mh-x-mailer-string
)
1075 (save-window-excursion
1076 ;; User would be confused if version info buffer disappeared magically,
1077 ;; so don't delete buffer if it already existed.
1078 (let ((info-buffer-exists-p (get-buffer mh-info-buffer
)))
1080 (set-buffer mh-info-buffer
)
1082 (search-forward-regexp "^nmh-\\(\\S +\\)")
1083 (search-forward-regexp "^MH \\(\\S +\\)" nil t
))
1084 (let ((x-mailer-mh (buffer-substring (match-beginning 1)
1086 (setq mh-x-mailer-string
1087 (format "MH-E %s; %s %s; %sEmacs %s"
1088 mh-version
(if mh-nmh-flag
"nmh" "MH") x-mailer-mh
1089 (if mh-xemacs-flag
"X" "GNU ")
1090 (cond ((not mh-xemacs-flag
) emacs-version
)
1091 ((string-match "[0-9.]*\\( +\([ a-z]+[0-9]+\)\\)?"
1093 (match-string 0 emacs-version
))
1096 emacs-minor-version
))))))
1097 (if (not info-buffer-exists-p
)
1098 (kill-buffer mh-info-buffer
)))))
1099 ;; Insert X-Mailer, but only if it doesn't already exist.
1101 (when (null (mh-goto-header-field "X-Mailer"))
1102 (mh-insert-fields "X-Mailer:" mh-x-mailer-string
))))
1104 (defun mh-regexp-in-field-p (regexp &rest fields
)
1105 "Non-nil means REGEXP was found in FIELDS."
1107 (let ((search-result nil
)
1110 (setq field
(car fields
))
1111 (if (and (mh-goto-header-field field
)
1113 regexp
(save-excursion (mh-header-field-end)(point)) t
))
1116 (setq fields
(cdr fields
))))
1119 (defun mh-insert-mail-followup-to ()
1120 "Insert Mail-Followup-To: if To or Cc match `mh-insert-mail-followup-to-list'."
1122 (if (and (or (mh-goto-header-field "To:")(mh-goto-header-field "cc:"))
1123 (not (mh-goto-header-field "Mail-Followup-To: ")))
1124 (let ((list mh-insert-mail-followup-to-list
))
1126 (let ((regexp (nth 0 (car list
)))
1127 (entry (nth 1 (car list
))))
1128 (when (mh-regexp-in-field-p regexp
"To:" "cc:")
1129 (if (mh-goto-header-field "Mail-Followup-To: ")
1131 (mh-goto-header-end 0)
1132 (insert "Mail-Followup-To: " entry
"\n")))
1133 (setq list
(cdr list
))))))))
1135 (defun mh-compose-and-send-mail (draft send-args
1136 sent-from-folder sent-from-msg
1138 annotate-char annotate-field
1140 "Edit and compose a draft message in buffer DRAFT and send or save it.
1141 SEND-ARGS is the argument passed to the send command.
1142 SENT-FROM-FOLDER is buffer containing scan listing of current folder, or
1144 SENT-FROM-MSG is the message number or sequence name or nil.
1145 The TO, SUBJECT, and CC fields are passed to the
1146 `mh-compose-letter-function'.
1147 If ANNOTATE-CHAR is non-null, it is used to notate the scan listing of the
1148 message. In that case, the ANNOTATE-FIELD is used to build a string
1149 for `mh-annotate-msg'.
1150 CONFIG is the window configuration to restore after sending the letter."
1151 (pop-to-buffer draft
)
1152 (if mh-insert-mail-followup-to-flag
(mh-insert-mail-followup-to))
1155 ;; mh-identity support
1156 (if (and (boundp 'mh-identity-default
)
1157 mh-identity-default
)
1158 (mh-insert-identity mh-identity-default
))
1159 (when (and (boundp 'mh-identity-list
)
1161 (mh-identity-make-menu)
1162 (easy-menu-add mh-identity-menu
))
1164 (setq mh-sent-from-folder sent-from-folder
)
1165 (setq mh-sent-from-msg sent-from-msg
)
1166 (setq mh-send-args send-args
)
1167 (setq mh-annotate-char annotate-char
)
1168 (setq mh-annotate-field annotate-field
)
1169 (setq mh-previous-window-config config
)
1170 (setq mode-line-buffer-identification
(list " {%b}"))
1172 (add-hook 'kill-buffer-hook
'mh-tidy-draft-buffer nil t
)
1173 (if (and (boundp 'mh-compose-letter-function
)
1174 mh-compose-letter-function
)
1175 ;; run-hooks will not pass arguments.
1176 (let ((value mh-compose-letter-function
))
1177 (if (and (listp value
) (not (eq (car value
) 'lambda
)))
1179 (funcall (car value
) to subject cc
)
1180 (setq value
(cdr value
)))
1181 (funcall mh-compose-letter-function to subject cc
)))))
1183 (defun mh-letter-mode-message ()
1184 "Display a help message for users of `mh-letter-mode'.
1185 This should be the last function called when composing the draft."
1186 (message "%s" (substitute-command-keys
1187 (concat "Type \\[mh-send-letter] to send message, "
1188 "\\[mh-help] for help."))))
1191 (defun mh-send-letter (&optional arg
)
1192 "Send the draft letter in the current buffer.
1193 If optional prefix argument ARG is provided, monitor delivery.
1194 The value of `mh-before-send-letter-hook' is a list of functions to be called,
1195 with no arguments, before doing anything.
1196 Run `\\[mh-edit-mhn]' if variable `mh-mhn-compose-insert-flag' is set.
1197 Run `\\[mh-mml-to-mime]' if variable `mh-mml-compose-insert-flag' is set.
1198 Insert X-Mailer field if variable `mh-insert-x-mailer-flag' is set.
1199 Insert X-Face field if the file specified by `mh-x-face-file' exists."
1201 (run-hooks 'mh-before-send-letter-hook
)
1203 ((and (boundp 'mh-mhn-compose-insert-flag
)
1204 mh-mhn-compose-insert-flag
)
1206 ((and (boundp 'mh-mml-compose-insert-flag
)
1207 mh-mml-compose-insert-flag
)
1209 (if mh-insert-x-mailer-flag
(mh-insert-x-mailer))
1212 (message "Sending...")
1213 (let ((draft-buffer (current-buffer))
1214 (file-name buffer-file-name
)
1215 (config mh-previous-window-config
)
1216 (coding-system-for-write
1217 (if (and (local-variable-p 'buffer-file-coding-system
1218 (current-buffer)) ;XEmacs needs two args
1219 ;; We're not sure why, but buffer-file-coding-system
1220 ;; tends to get set to undecided-unix.
1221 (not (memq buffer-file-coding-system
1222 '(undecided undecided-unix undecided-dos
))))
1223 buffer-file-coding-system
1224 (or (and (boundp 'sendmail-coding-system
) sendmail-coding-system
)
1225 (and (boundp 'default-buffer-file-coding-system
)
1226 default-buffer-file-coding-system
)
1228 ;; The default BCC encapsulation will make a MIME message unreadable.
1229 ;; With nmh use the -mime arg to prevent this.
1230 (if (and mh-nmh-flag
1231 (mh-goto-header-field "Bcc:")
1232 (mh-goto-header-field "Content-Type:"))
1233 (setq mh-send-args
(format "-mime %s" mh-send-args
)))
1235 (pop-to-buffer "MH mail delivery")
1237 (mh-exec-cmd-output mh-send-prog t
"-watch" "-nopush"
1238 "-nodraftfolder" mh-send-args file-name
)
1239 (goto-char (point-max)) ; show the interesting part
1241 (set-buffer draft-buffer
)) ; for annotation below
1243 (mh-exec-cmd-daemon mh-send-prog nil
"-nodraftfolder" "-noverbose"
1244 mh-send-args file-name
)))
1245 (if mh-annotate-char
1246 (mh-annotate-msg mh-sent-from-msg
1249 "-component" mh-annotate-field
1250 "-text" (format "\"%s %s\""
1251 (mh-get-header-field "To:")
1252 (mh-get-header-field "Cc:"))))
1254 (cond ((or (not arg
)
1255 (y-or-n-p "Kill draft buffer? "))
1256 (kill-buffer draft-buffer
)
1258 (set-window-configuration config
))))
1260 (message "Sending...done")
1261 (message "Sending...backgrounded"))))
1264 (defun mh-insert-letter (folder message verbatim
)
1265 "Insert a message into the current letter.
1266 Removes the header fields according to the variable `mh-invisible-headers'.
1267 Prefixes each non-blank line with `mh-ins-buf-prefix', unless
1268 `mh-yank-from-start-of-msg' is set for supercite in which case supercite is
1269 used to format the message.
1270 Prompts for FOLDER and MESSAGE. If prefix argument VERBATIM provided, do
1271 not indent and do not delete headers. Leaves the mark before the letter
1272 and point after it."
1274 (list (mh-prompt-for-folder "Message from" mh-sent-from-folder nil
)
1275 (read-input (format "Message number%s: "
1276 (if (numberp mh-sent-from-msg
)
1277 (format " [%d]" mh-sent-from-msg
)
1279 current-prefix-arg
))
1281 (narrow-to-region (point) (point))
1282 (let ((start (point-min)))
1283 (if (equal message
"") (setq message
(int-to-string mh-sent-from-msg
)))
1284 (insert-file-contents
1285 (expand-file-name message
(mh-expand-file-name folder
)))
1286 (when (not verbatim
)
1287 (mh-clean-msg-header start mh-invisible-headers mh-visible-headers
)
1288 (goto-char (point-max)) ;Needed for sc-cite-original
1289 (push-mark) ;Needed for sc-cite-original
1290 (goto-char (point-min)) ;Needed for sc-cite-original
1291 (mh-insert-prefix-string mh-ins-buf-prefix
)))))
1293 (defun mh-extract-from-attribution ()
1294 "Extract phrase or comment from From header field."
1296 (if (not (mh-goto-header-field "From: "))
1298 (skip-chars-forward " ")
1300 ((looking-at "\"\\([^\"\n]+\\)\" \\(<.+>\\)")
1301 (format "%s %s %s" (match-string 1)(match-string 2)
1302 mh-extract-from-attribution-verb
))
1303 ((looking-at "\\([^<\n]+<.+>\\)$")
1304 (format "%s %s" (match-string 1) mh-extract-from-attribution-verb
))
1305 ((looking-at "\\([^ ]+@[^ ]+\\) +(\\(.+\\))$")
1306 (format "%s <%s> %s" (match-string 2)(match-string 1)
1307 mh-extract-from-attribution-verb
))
1308 ((looking-at " *\\(.+\\)$")
1309 (format "%s %s" (match-string 1) mh-extract-from-attribution-verb
))))))
1312 (defun mh-yank-cur-msg ()
1313 "Insert the current message into the draft buffer.
1314 Prefix each non-blank line in the message with the string in
1315 `mh-ins-buf-prefix'. If a region is set in the message's buffer, then
1316 only the region will be inserted. Otherwise, the entire message will
1317 be inserted if `mh-yank-from-start-of-msg' is non-nil. If this variable
1318 is nil, the portion of the message following the point will be yanked.
1319 If `mh-delete-yanked-msg-window-flag' is non-nil, any window displaying the
1320 yanked message will be deleted."
1322 (if (and mh-sent-from-folder
1323 (save-excursion (set-buffer mh-sent-from-folder
) mh-show-buffer
)
1324 (save-excursion (set-buffer mh-sent-from-folder
)
1325 (get-buffer mh-show-buffer
))
1327 (let ((to-point (point))
1328 (to-buffer (current-buffer)))
1329 (set-buffer mh-sent-from-folder
)
1330 (if mh-delete-yanked-msg-window-flag
1331 (delete-windows-on mh-show-buffer
))
1332 (set-buffer mh-show-buffer
) ; Find displayed message
1333 (let* ((from-attr (mh-extract-from-attribution))
1334 (yank-region (mh-mark-active-p nil
))
1336 (cond ((and yank-region
1337 (or (eq 'supercite mh-yank-from-start-of-msg
)
1338 (eq 'autosupercite mh-yank-from-start-of-msg
)
1339 (eq t mh-yank-from-start-of-msg
)))
1340 ;; supercite needs the full header
1342 (buffer-substring (point-min) (mail-header-end))
1344 (buffer-substring (region-beginning) (region-end))))
1346 (buffer-substring (region-beginning) (region-end)))
1347 ((or (eq 'body mh-yank-from-start-of-msg
)
1349 mh-yank-from-start-of-msg
)
1351 mh-yank-from-start-of-msg
))
1354 (goto-char (point-min))
1355 (mh-goto-header-end 1)
1358 ((or (eq 'supercite mh-yank-from-start-of-msg
)
1359 (eq 'autosupercite mh-yank-from-start-of-msg
)
1360 (eq t mh-yank-from-start-of-msg
))
1361 (buffer-substring (point-min) (point-max)))
1363 (buffer-substring (point) (point-max))))))
1364 (set-buffer to-buffer
)
1366 (narrow-to-region to-point to-point
)
1367 (insert (mh-filter-out-non-text mh-ins-str
))
1368 (goto-char (point-max)) ;Needed for sc-cite-original
1369 (push-mark) ;Needed for sc-cite-original
1370 (goto-char (point-min)) ;Needed for sc-cite-original
1371 (mh-insert-prefix-string mh-ins-buf-prefix
)
1372 (if (or (eq 'attribution mh-yank-from-start-of-msg
)
1373 (eq 'autoattrib mh-yank-from-start-of-msg
))
1374 (insert from-attr
"\n\n"))
1375 ;; If the user has selected a region, he has already "edited" the
1376 ;; text, so leave the cursor at the end of the yanked text. In
1377 ;; either case, leave a mark at the opposite end of the included
1378 ;; text to make it easy to jump or delete to the other end of the
1381 (goto-char (point-max))
1382 (if (null yank-region
)
1383 (mh-exchange-point-and-mark-preserving-active-mark)))))
1384 (error "There is no current message")))
1386 (defun mh-filter-out-non-text (string)
1387 "Return STRING but without adornments such as MIME buttons and smileys."
1389 ;; Insert the string to filter
1391 (goto-char (point-min))
1393 ;; Remove the MIME buttons
1394 (let ((can-move-forward t
)
1396 (while can-move-forward
1397 (cond ((and (not (get-text-property (point) 'mh-data
))
1399 (delete-region (1- (point)) (point))
1400 (setq in-button nil
))
1401 ((get-text-property (point) 'mh-data
)
1402 (delete-region (point)
1403 (save-excursion (forward-line) (point)))
1405 (t (setq can-move-forward
(= (forward-line) 0))))))
1407 ;; Return the contents without properties... This gets rid of emphasis
1409 (buffer-substring-no-properties (point-min) (point-max))))
1411 (defun mh-insert-prefix-string (mh-ins-string)
1412 "Insert prefix string before each line in buffer.
1413 The inserted letter is cited using `sc-cite-original' if
1414 `mh-yank-from-start-of-msg' is one of 'supercite or 'autosupercite. Otherwise,
1415 simply insert MH-INS-STRING before each line."
1416 (goto-char (point-min))
1417 (cond ((or (eq mh-yank-from-start-of-msg
'supercite
)
1418 (eq mh-yank-from-start-of-msg
'autosupercite
))
1421 (run-hooks 'mail-citation-hook
))
1422 (mh-yank-hooks ;old hook name
1423 (run-hooks 'mh-yank-hooks
))
1425 (or (bolp) (forward-line 1))
1426 (while (< (point) (point-max))
1427 (insert mh-ins-string
)
1429 (goto-char (point-min))))) ;leave point like sc-cite-original
1432 (defun mh-fully-kill-draft ()
1433 "Kill the draft message file and the draft message buffer.
1434 Use \\[kill-buffer] if you don't want to delete the draft message file."
1436 (if (y-or-n-p "Kill draft message? ")
1437 (let ((config mh-previous-window-config
))
1438 (if (file-exists-p buffer-file-name
)
1439 (delete-file buffer-file-name
))
1440 (set-buffer-modified-p nil
)
1441 (kill-buffer (buffer-name))
1444 (set-window-configuration config
)))
1445 (error "Message not killed")))
1447 (defun mh-current-fill-prefix ()
1448 "Return the `fill-prefix' on the current line as a string."
1451 ;; This assumes that the major-mode sets up adaptive-fill-regexp
1452 ;; correctly such as mh-letter-mode or sendmail.el's mail-mode. But
1453 ;; perhaps I should use the variable and simply inserts its value here,
1454 ;; and set it locally in a let scope. --psg
1455 (if (re-search-forward adaptive-fill-regexp nil t
)
1460 (defun mh-open-line ()
1461 "Insert a newline and leave point after it.
1462 In addition, insert newline and quoting characters before text after point.
1463 This is useful in breaking up paragraphs in replies."
1465 (let ((column (current-column))
1466 (prefix (mh-current-fill-prefix)))
1467 (if (> (length prefix
) column
)
1468 (message "Sorry, point seems to be within the line prefix")
1471 (while (> column
(current-column))
1473 (forward-line -
1))))
1476 (defun mh-letter-complete (arg)
1477 "Perform completion on header field or word preceding point.
1478 Alias completion is done within the mail header on selected fields and
1479 by the function designated by `mh-letter-complete-function' elsewhere,
1480 passing the prefix ARG if any."
1482 (let ((case-fold-search t
))
1483 (if (and (mh-in-header-p)
1485 (mh-header-field-beginning)
1486 (looking-at "^.*\\(to\\|cc\\|from\\):")))
1487 (mh-alias-letter-expand-alias)
1488 (funcall mh-letter-complete-function arg
))))
1490 ;;; Build the letter-mode keymap:
1491 ;;; If this changes, modify mh-letter-mode-help-messages accordingly, above.
1492 (gnus-define-keys mh-letter-mode-map
1494 "\C-c\C-c" mh-send-letter
1495 "\C-c\C-d" mh-insert-identity
1496 "\C-c\C-e" mh-edit-mhn
1497 "\C-c\C-f\C-b" mh-to-field
1498 "\C-c\C-f\C-c" mh-to-field
1499 "\C-c\C-f\C-d" mh-to-field
1500 "\C-c\C-f\C-f" mh-to-fcc
1501 "\C-c\C-f\C-r" mh-to-field
1502 "\C-c\C-f\C-s" mh-to-field
1503 "\C-c\C-f\C-t" mh-to-field
1504 "\C-c\C-fb" mh-to-field
1505 "\C-c\C-fc" mh-to-field
1506 "\C-c\C-fd" mh-to-field
1507 "\C-c\C-ff" mh-to-fcc
1508 "\C-c\C-fr" mh-to-field
1509 "\C-c\C-fs" mh-to-field
1510 "\C-c\C-ft" mh-to-field
1511 "\C-c\C-i" mh-insert-letter
1512 "\C-c\C-m\C-e" mh-mml-secure-message-encrypt-pgpmime
1513 "\C-c\C-m\C-f" mh-compose-forward
1514 "\C-c\C-m\C-i" mh-compose-insertion
1515 "\C-c\C-m\C-m" mh-mml-to-mime
1516 "\C-c\C-m\C-s" mh-mml-secure-message-sign-pgpmime
1517 "\C-c\C-m\C-u" mh-revert-mhn-edit
1518 "\C-c\C-me" mh-mml-secure-message-encrypt-pgpmime
1519 "\C-c\C-mf" mh-compose-forward
1520 "\C-c\C-mi" mh-compose-insertion
1521 "\C-c\C-mm" mh-mml-to-mime
1522 "\C-c\C-ms" mh-mml-secure-message-sign-pgpmime
1523 "\C-c\C-mu" mh-revert-mhn-edit
1524 "\C-c\C-o" mh-open-line
1525 "\C-c\C-q" mh-fully-kill-draft
1526 "\C-c\C-\\" mh-fully-kill-draft
;if no C-q
1527 "\C-c\C-s" mh-insert-signature
1528 "\C-c\C-^" mh-insert-signature
;if no C-s
1529 "\C-c\C-w" mh-check-whom
1530 "\C-c\C-y" mh-yank-cur-msg
1531 "\M-\t" mh-letter-complete
)
1533 ;; "C-c /" prefix is used in mh-letter-mode by pgp.el and mailcrypt.el.
1537 ;;; Local Variables:
1538 ;;; indent-tabs-mode: nil
1539 ;;; sentence-end-double-space: nil
1542 ;;; mh-comp.el ends here